summaryrefslogtreecommitdiff
path: root/Master
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
commit320d8694fec25ed148613684543b5a0504a046ae (patch)
tree0ddcf933d3acd3c98a387fa2bf73d0554ca6e50d /Master
parent779e71f16ca01a6244b632b95bdb461fec163b34 (diff)
New tlperl part XIV
git-svn-id: svn://tug.org/texlive/trunk@21436 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master')
-rw-r--r--Master/tlpkg/tlperl/lib/App/Cpan.pm1067
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove.pm774
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State.pm517
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm233
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm153
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Extract.pm1511
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar.pm2146
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm86
-rw-r--r--Master/tlpkg/tlperl/lib/Archive/Tar/File.pm660
-rw-r--r--Master/tlpkg/tlperl/lib/Attribute/Handlers.pm924
-rw-r--r--Master/tlpkg/tlperl/lib/B/Concise.pm1836
-rw-r--r--Master/tlpkg/tlperl/lib/B/Debug.pm424
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm4875
-rw-r--r--Master/tlpkg/tlperl/lib/B/Lint.pm792
-rw-r--r--Master/tlpkg/tlperl/lib/B/Lint/Debug.pm67
-rw-r--r--Master/tlpkg/tlperl/lib/B/Showlex.pm205
-rw-r--r--Master/tlpkg/tlperl/lib/B/Terse.pm102
-rw-r--r--Master/tlpkg/tlperl/lib/B/Xref.pm431
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Apache.pm27
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Carp.pm601
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Cookie.pm549
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Fast.pm224
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Pretty.pm312
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Push.pm325
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Switch.pm28
-rw-r--r--Master/tlpkg/tlperl/lib/CGI/Util.pm392
-rw-r--r--Master/tlpkg/tlperl/lib/Carp/Heavy.pm10
-rw-r--r--Master/tlpkg/tlperl/lib/Class/ISA.pm218
-rw-r--r--Master/tlpkg/tlperl/lib/Class/Struct.pm636
-rw-r--r--Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm355
-rw-r--r--Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm1419
-rw-r--r--Master/tlpkg/tlperl/lib/Compress/Zlib.pm1494
-rw-r--r--Master/tlpkg/tlperl/lib/Config/Extensions.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm53
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm86
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter/null.pm52
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm51
-rw-r--r--Master/tlpkg/tlperl/lib/Data/Dumper.pm1306
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf.pm238
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/V.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test1_t18
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test1_v24
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test2_t21
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test2_v36
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test3_t19
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test3_v29
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test4_t24
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test4_v36
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test5_t25
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test5_v15
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test6_t29
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test6_v16
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test7_t9
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test7_v10
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test8_t15
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/DProf/test8_v11
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm128
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/PPPort.pm8269
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/Peek.pm570
-rw-r--r--Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm152
-rw-r--r--Master/tlpkg/tlperl/lib/Digest/MD5.pm376
-rw-r--r--Master/tlpkg/tlperl/lib/Digest/SHA.pm669
-rw-r--r--Master/tlpkg/tlperl/lib/Digest/SHA1.pm246
-rw-r--r--Master/tlpkg/tlperl/lib/Digest/base.pm100
-rw-r--r--Master/tlpkg/tlperl/lib/Digest/file.pm85
-rw-r--r--Master/tlpkg/tlperl/lib/Exporter/Heavy.pm248
-rw-r--r--Master/tlpkg/tlperl/lib/File/Basename.pm402
-rw-r--r--Master/tlpkg/tlperl/lib/File/CheckTree.pm238
-rw-r--r--Master/tlpkg/tlperl/lib/File/Compare.pm182
-rw-r--r--Master/tlpkg/tlperl/lib/File/Copy.pm656
-rw-r--r--Master/tlpkg/tlperl/lib/File/DosGlob.pm571
-rw-r--r--Master/tlpkg/tlperl/lib/File/Fetch.pm1466
-rw-r--r--Master/tlpkg/tlperl/lib/File/Find.pm1349
-rw-r--r--Master/tlpkg/tlperl/lib/File/Glob.pm496
-rw-r--r--Master/tlpkg/tlperl/lib/File/GlobMapper.pm679
-rw-r--r--Master/tlpkg/tlperl/lib/File/Path.pm981
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec.pm336
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm155
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm79
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Functions.pm110
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Mac.pm781
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/OS2.pm274
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Unix.pm521
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/VMS.pm1141
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Win32.pm444
-rw-r--r--Master/tlpkg/tlperl/lib/File/Temp.pm2452
-rw-r--r--Master/tlpkg/tlperl/lib/File/Which.pm254
-rw-r--r--Master/tlpkg/tlperl/lib/File/stat.pm346
-rw-r--r--Master/tlpkg/tlperl/lib/Filter/Simple.pm797
-rw-r--r--Master/tlpkg/tlperl/lib/Filter/Util/Call.pm498
-rw-r--r--Master/tlpkg/tlperl/lib/Getopt/Long.pm2649
-rw-r--r--Master/tlpkg/tlperl/lib/Getopt/Std.pm295
-rw-r--r--Master/tlpkg/tlperl/lib/Hash/Util.pm520
-rw-r--r--Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm860
-rw-r--r--Master/tlpkg/tlperl/lib/I18N/Collate.pm196
-rw-r--r--Master/tlpkg/tlperl/lib/I18N/LangTags.pm887
-rw-r--r--Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm237
-rw-r--r--Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm1779
-rw-r--r--Master/tlpkg/tlperl/lib/IPC/Cmd.pm1646
-rw-r--r--Master/tlpkg/tlperl/lib/IPC/Open2.pm121
-rw-r--r--Master/tlpkg/tlperl/lib/IPC/Open3.pm376
-rw-r--r--Master/tlpkg/tlperl/lib/List/Util.pm233
-rw-r--r--Master/tlpkg/tlperl/lib/List/Util/PP.pm83
-rw-r--r--Master/tlpkg/tlperl/lib/List/Util/XS.pm45
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Constants.pm31
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Constants.pod76
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Country.pm550
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Country.pod306
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Currency.pm356
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Currency.pod191
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Language.pm315
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Language.pod158
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext.pm456
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext.pod1326
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm328
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm49
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm341
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod775
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Script.pm294
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Script.pod253
-rw-r--r--Master/tlpkg/tlperl/lib/Log/Message.pm600
-rw-r--r--Master/tlpkg/tlperl/lib/Log/Message/Config.pm197
-rw-r--r--Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm191
-rw-r--r--Master/tlpkg/tlperl/lib/Log/Message/Item.pm192
-rw-r--r--Master/tlpkg/tlperl/lib/Log/Message/Simple.pm293
-rw-r--r--Master/tlpkg/tlperl/lib/MIME/Base64.pm175
-rw-r--r--Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm114
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigFloat.pm4402
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm58
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigInt.pm5115
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm2612
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm329
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm125
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm47
-rw-r--r--Master/tlpkg/tlperl/lib/Math/BigRat.pm2020
-rw-r--r--Master/tlpkg/tlperl/lib/Math/Complex.pm2093
-rw-r--r--Master/tlpkg/tlperl/lib/Math/Trig.pm768
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm31
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/Expire.pm365
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm52
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm49
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm77
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm75
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize/Storable.pm72
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Cmd.pm783
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Config.pm312
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Domain.pm347
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP.pm1829
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP/A.pm111
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP/E.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP/I.pm80
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP/L.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm124
-rw-r--r--Master/tlpkg/tlperl/lib/Net/NNTP.pm1140
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Netrc.pm325
-rw-r--r--Master/tlpkg/tlperl/lib/Net/POP3.pm742
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Ping.pm1777
-rw-r--r--Master/tlpkg/tlperl/lib/Net/SMTP.pm867
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Time.pm151
-rw-r--r--Master/tlpkg/tlperl/lib/Net/hostent.pm151
-rw-r--r--Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod303
-rw-r--r--Master/tlpkg/tlperl/lib/Net/netent.pm169
-rw-r--r--Master/tlpkg/tlperl/lib/Net/protoent.pm96
-rw-r--r--Master/tlpkg/tlperl/lib/Net/servent.pm113
-rw-r--r--Master/tlpkg/tlperl/lib/Object/Accessor.pm819
-rw-r--r--Master/tlpkg/tlperl/lib/Package/Constants.pm106
-rw-r--r--Master/tlpkg/tlperl/lib/Params/Check.pm712
-rw-r--r--Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm437
-rw-r--r--Master/tlpkg/tlperl/lib/PerlIO/encoding.pm53
-rw-r--r--Master/tlpkg/tlperl/lib/PerlIO/scalar.pm41
-rw-r--r--Master/tlpkg/tlperl/lib/PerlIO/via.pm243
-rw-r--r--Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm94
-rw-r--r--Master/tlpkg/tlperl/lib/Scalar/Util.pm283
-rw-r--r--Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm109
-rw-r--r--Master/tlpkg/tlperl/lib/Search/Dict.pm108
-rw-r--r--Master/tlpkg/tlperl/lib/Sys/Hostname.pm165
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Base.pm129
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm449
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm148
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm91
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm202
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm219
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm58
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm110
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm183
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Harness.pm830
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Object.pm139
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser.pm1873
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm416
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm580
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm165
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm106
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm377
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm112
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm171
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm195
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm300
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm61
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm120
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm274
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm51
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm62
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm189
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm312
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm107
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm53
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm173
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm326
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm72
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm333
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm255
-rw-r--r--Master/tlpkg/tlperl/lib/Term/ANSIColor.pm609
-rw-r--r--Master/tlpkg/tlperl/lib/Term/Cap.pm799
-rw-r--r--Master/tlpkg/tlperl/lib/Term/Complete.pm188
-rw-r--r--Master/tlpkg/tlperl/lib/Term/ReadLine.pm416
-rw-r--r--Master/tlpkg/tlperl/lib/Term/UI.pm620
-rw-r--r--Master/tlpkg/tlperl/lib/Term/UI/History.pm137
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Builder.pm2501
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Builder/Module.pm173
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm603
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm51
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Harness.pm585
-rw-r--r--Master/tlpkg/tlperl/lib/Test/More.pm1776
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Simple.pm214
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Tutorial.pod604
-rw-r--r--Master/tlpkg/tlperl/lib/Text/Abbrev.pm84
-rw-r--r--Master/tlpkg/tlperl/lib/Text/Balanced.pm2281
-rw-r--r--Master/tlpkg/tlperl/lib/Text/ParseWords.pm294
-rw-r--r--Master/tlpkg/tlperl/lib/Text/Soundex.pm260
-rw-r--r--Master/tlpkg/tlperl/lib/Text/Tabs.pm136
-rw-r--r--Master/tlpkg/tlperl/lib/Text/Wrap.pm265
-rw-r--r--Master/tlpkg/tlperl/lib/Thread/Queue.pm481
-rw-r--r--Master/tlpkg/tlperl/lib/Thread/Semaphore.pm170
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Array.pm287
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/File.pm2632
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Handle.pm201
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Hash.pm257
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm62
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Memoize.pm128
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/RefHash.pm274
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Registry.pm45
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Scalar.pm163
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/StdHandle.pm71
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm215
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Watch.pm560
-rw-r--r--Master/tlpkg/tlperl/lib/Time/HiRes.pm591
-rw-r--r--Master/tlpkg/tlperl/lib/Time/Local.pm341
-rw-r--r--Master/tlpkg/tlperl/lib/Time/Piece.pm859
-rw-r--r--Master/tlpkg/tlperl/lib/Time/Seconds.pm230
-rw-r--r--Master/tlpkg/tlperl/lib/Time/gmtime.pm91
-rw-r--r--Master/tlpkg/tlperl/lib/Time/localtime.pm86
-rw-r--r--Master/tlpkg/tlperl/lib/Time/tm.pm33
-rw-r--r--Master/tlpkg/tlperl/lib/User/grent.pm95
-rw-r--r--Master/tlpkg/tlperl/lib/User/pwent.pm298
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm778
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Callback.pm174
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Struct.pm532
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Test.pm111
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Type.pm453
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Shortcut.pm752
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm3809
-rw-r--r--Master/tlpkg/tlperl/lib/Win32API/File.pm3035
-rw-r--r--Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc165
-rw-r--r--Master/tlpkg/tlperl/lib/Win32API/Registry.pm1775
-rw-r--r--Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc87
-rw-r--r--Master/tlpkg/tlperl/lib/autodie/exception.pm741
-rw-r--r--Master/tlpkg/tlperl/lib/autodie/exception/system.pm81
-rw-r--r--Master/tlpkg/tlperl/lib/autodie/hints.pm598
-rw-r--r--Master/tlpkg/tlperl/lib/encoding/warnings.pm239
-rw-r--r--Master/tlpkg/tlperl/lib/inc/latest.pm246
-rw-r--r--Master/tlpkg/tlperl/lib/inc/latest/private.pm101
-rw-r--r--Master/tlpkg/tlperl/lib/overload/numbers.pm163
-rw-r--r--Master/tlpkg/tlperl/lib/threads/shared.pm616
-rw-r--r--Master/tlpkg/tlperl/lib/version/Internals.pod698
-rw-r--r--Master/tlpkg/tlperl/lib/warnings/register.pm51
279 files changed, 145534 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/App/Cpan.pm b/Master/tlpkg/tlperl/lib/App/Cpan.pm
new file mode 100644
index 00000000000..cfc12908e52
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Cpan.pm
@@ -0,0 +1,1067 @@
+package App::Cpan;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+$VERSION = '1.5701';
+
+=head1 NAME
+
+App::Cpan - easily interact with CPAN from the command line
+
+=head1 SYNOPSIS
+
+ # with arguments and no switches, installs specified modules
+ cpan module_name [ module_name ... ]
+
+ # with switches, installs modules with extra behavior
+ cpan [-cfFimt] module_name [ module_name ... ]
+
+ # use local::lib
+ cpan -l module_name [ module_name ... ]
+
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
+
+ # without arguments, starts CPAN.pm shell
+ cpan
+
+ # without arguments, but some switches
+ cpan [-ahruvACDLO]
+
+=head1 DESCRIPTION
+
+This script provides a command interface (not a shell) to CPAN. At the
+moment it uses CPAN.pm to do the work, but it is not a one-shot command
+runner for CPAN.pm.
+
+=head2 Options
+
+=over 4
+
+=item -a
+
+Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
+
+=item -A module [ module ... ]
+
+Shows the primary maintainers for the specified modules.
+
+=item -c module
+
+Runs a `make clean` in the specified module's directories.
+
+=item -C module [ module ... ]
+
+Show the F<Changes> files for the specified modules
+
+=item -D module [ module ... ]
+
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
+
+=item -f
+
+Force the specified action, when it normally would have failed. Use this
+to install a module even if its tests fail. When you use this option,
+-i is not optional for installing a module when you need to force it:
+
+ % cpan -f -i Module::Foo
+
+=item -F
+
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
+this since you might end up with multiple scripts trying to muck in the
+same directory. This isn't so much of a concern if you're loading a special
+config with C<-j>, and that config sets up its own work directories.
+
+=item -g module [ module ... ]
+
+Downloads to the current directory the latest distribution of the module.
+
+=item -G module [ module ... ]
+
+UNIMPLEMENTED
+
+Download to the current directory the latest distribution of the
+modules, unpack each distribution, and create a git repository for each
+distribution.
+
+If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
+distribution.
+
+=item -h
+
+Print a help message and exit. When you specify C<-h>, it ignores all
+of the other options and arguments.
+
+=item -i
+
+Install the specified modules.
+
+=item -j Config.pm
+
+Load the file that has the CPAN configuration data. This should have the
+same format as the standard F<CPAN/Config.pm> file, which defines
+C<$CPAN::Config> as an anonymous hash.
+
+=item -J
+
+Dump the configuration in the same format that CPAN.pm uses. This is useful
+for checking the configuration as well as using the dump as a starting point
+for a new, custom configuration.
+
+=item -l
+
+Use C<local::lib>.
+
+=item -L author [ author ... ]
+
+List the modules by the specified authors.
+
+=item -m
+
+Make the specified modules.
+
+=item -O
+
+Show the out-of-date modules.
+
+=item -t
+
+Run a `make test` on the specified modules.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=item -u
+
+Upgrade all installed modules. Blindly doing this can really break things,
+so keep a backup.
+
+=item -v
+
+Print the script version and CPAN.pm version then exit.
+
+=back
+
+=head2 Examples
+
+ # print a help message
+ cpan -h
+
+ # print the version numbers
+ cpan -v
+
+ # create an autobundle
+ cpan -a
+
+ # recompile modules
+ cpan -r
+
+ # upgrade all installed modules
+ cpan -u
+
+ # install modules ( sole -i is optional )
+ cpan -i Netscape::Booksmarks Business::ISBN
+
+ # force install modules ( must use -i )
+ cpan -fi CGI::Minimal URI
+
+
+=head2 Methods
+
+=over 4
+
+=cut
+
+use autouse Carp => qw(carp croak cluck);
+use CPAN ();
+use autouse Cwd => qw(cwd);
+use autouse 'Data::Dumper' => qw(Dumper);
+use File::Spec::Functions;
+use File::Basename;
+
+use Getopt::Std;
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# Internal constants
+use constant TRUE => 1;
+use constant FALSE => 0;
+
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# The return values
+use constant HEY_IT_WORKED => 0;
+use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
+use constant ITS_NOT_MY_FAULT => 2;
+use constant THE_PROGRAMMERS_AN_IDIOT => 4;
+use constant A_MODULE_FAILED_TO_INSTALL => 8;
+
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# set up the order of options that we layer over CPAN::Shell
+BEGIN { # most of this should be in methods
+use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
+ %Method_table %Method_table_index );
+
+@META_OPTIONS = qw( h v g G C A D O l L a r j: J );
+
+$Default = 'default';
+
+%CPAN_METHODS = ( # map switches to method names in CPAN::Shell
+ $Default => 'install',
+ 'c' => 'clean',
+ 'f' => 'force',
+ 'i' => 'install',
+ 'm' => 'make',
+ 't' => 'test',
+ 'u' => 'upgrade',
+ );
+@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
+
+@option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
+
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# map switches to the subroutines in this script, along with other information.
+# use this stuff instead of hard-coded indices and values
+sub NO_ARGS () { 0 }
+sub ARGS () { 1 }
+sub GOOD_EXIT () { 0 }
+
+%Method_table = (
+# key => [ sub ref, takes args?, exit value, description ]
+
+ # options that do their thing first, then exit
+ h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ],
+ v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ],
+
+ # options that affect other options
+ j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ],
+ J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ],
+ F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ],
+
+ # options that do their one thing
+ g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
+ G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
+
+ C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
+ A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
+ D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ],
+ O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ],
+
+ l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ],
+
+ L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ],
+ a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ],
+ r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
+ u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
+
+ c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ],
+ f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ],
+ i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ],
+ 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ],
+ t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ],
+
+ );
+
+%Method_table_index = (
+ code => 0,
+ takes_args => 1,
+ exit_value => 2,
+ description => 3,
+ );
+}
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# finally, do some argument processing
+
+sub _stupid_interface_hack_for_non_rtfmers
+ {
+ no warnings 'uninitialized';
+ shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
+ }
+
+sub _process_options
+ {
+ my %options;
+
+ # if no arguments, just drop into the shell
+ if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
+ else
+ {
+ Getopt::Std::getopts(
+ join( '', @option_order ), \%options );
+ \%options;
+ }
+ }
+
+sub _process_setup_options
+ {
+ my( $class, $options ) = @_;
+
+ if( $options->{j} )
+ {
+ $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
+ delete $options->{j};
+ }
+ else
+ {
+ # this is what CPAN.pm would do otherwise
+ CPAN::HandleConfig->load(
+ # be_silent => 1, # candidate to be ripped out forever
+ write_file => 0,
+ );
+ }
+
+ if( $options->{F} )
+ {
+ $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} );
+ delete $options->{F};
+ }
+
+ my $option_count = grep { $options->{$_} } @option_order;
+ no warnings 'uninitialized';
+ $option_count -= $options->{'f'}; # don't count force
+
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # if there are no options, set -i (this line fixes RT ticket 16915)
+ $options->{i}++ unless $option_count;
+ }
+
+
+=item run()
+
+Just do it.
+
+The C<run> method returns 0 on success and a postive number on
+failure. See the section on EXIT CODES for details on the values.
+
+=cut
+
+my $logger;
+
+sub run
+ {
+ my $class = shift;
+
+ my $return_value = HEY_IT_WORKED; # assume that things will work
+
+ $logger = $class->_init_logger;
+ $logger->debug( "Using logger from @{[ref $logger]}" );
+
+ $class->_hook_into_CPANpm_report;
+ $logger->debug( "Hooked into output" );
+
+ $class->_stupid_interface_hack_for_non_rtfmers;
+ $logger->debug( "Patched cargo culting" );
+
+ my $options = $class->_process_options;
+ $logger->debug( "Options are @{[Dumper($options)]}" );
+
+ $class->_process_setup_options( $options );
+
+ OPTION: foreach my $option ( @option_order )
+ {
+ next unless $options->{$option};
+
+ my( $sub, $takes_args, $description ) =
+ map { $Method_table{$option}[ $Method_table_index{$_} ] }
+ qw( code takes_args );
+
+ unless( ref $sub eq ref sub {} )
+ {
+ $return_value = THE_PROGRAMMERS_AN_IDIOT;
+ last OPTION;
+ }
+
+ $logger->info( "$description -- ignoring other arguments" )
+ if( @ARGV && ! $takes_args );
+
+ $return_value = $sub->( \ @ARGV, $options );
+
+ last;
+ }
+
+ return $return_value;
+ }
+
+{
+package Local::Null::Logger;
+
+sub new { bless \ my $x, $_[0] }
+sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} }
+sub DESTROY { 1 }
+}
+
+sub _init_logger
+ {
+ my $log4perl_loaded = eval "require Log::Log4perl; 1";
+
+ unless( $log4perl_loaded )
+ {
+ $logger = Local::Null::Logger->new;
+ return $logger;
+ }
+
+ my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
+
+ Log::Log4perl::init( \ <<"HERE" );
+log4perl.rootLogger=$LEVEL, A1
+log4perl.appender.A1=Log::Log4perl::Appender::Screen
+log4perl.appender.A1.layout=PatternLayout
+log4perl.appender.A1.layout.ConversionPattern=%m%n
+HERE
+
+ $logger = Log::Log4perl->get_logger( 'App::Cpan' );
+ }
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+
+sub _default
+ {
+ my( $args, $options ) = @_;
+
+ my $switch = '';
+
+ # choose the option that we're going to use
+ # we'll deal with 'f' (force) later, so skip it
+ foreach my $option ( @CPAN_OPTIONS )
+ {
+ next if $option eq 'f';
+ next unless $options->{$option};
+ $switch = $option;
+ last;
+ }
+
+ # 1. with no switches, but arguments, use the default switch (install)
+ # 2. with no switches and no args, start the shell
+ # 3. With a switch but no args, die! These switches need arguments.
+ if( not $switch and @$args ) { $switch = $Default; }
+ elsif( not $switch and not @$args ) { return CPAN::shell() }
+ elsif( $switch and not @$args )
+ { die "Nothing to $CPAN_METHODS{$switch}!\n"; }
+
+ # Get and check the method from CPAN::Shell
+ my $method = $CPAN_METHODS{$switch};
+ die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );
+
+ # call the CPAN::Shell method, with force if specified
+ my $action = do {
+ if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
+ else { sub { CPAN::Shell->$method( @_ ) } }
+ };
+
+ # How do I handle exit codes for multiple arguments?
+ my $errors = 0;
+
+ foreach my $arg ( @$args )
+ {
+ _clear_cpanpm_output();
+ $action->( $arg );
+
+ $errors += defined _cpanpm_output_indicates_failure();
+ }
+
+ $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED;
+ }
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+
+=for comment
+
+CPAN.pm sends all the good stuff either to STDOUT. I have to intercept
+that output so I can find out what happened.
+
+=cut
+
+{
+my $scalar = '';
+
+sub _hook_into_CPANpm_report
+ {
+ no warnings 'redefine';
+
+ *CPAN::Shell::myprint = sub {
+ my($self,$what) = @_;
+ $scalar .= $what if defined $what;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_print}||'bold blue on_white',
+ );
+ };
+
+ *CPAN::Shell::mywarn = sub {
+ my($self,$what) = @_;
+ $scalar .= $what if defined $what;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_warn}||'bold red on_white'
+ );
+ };
+
+ }
+
+sub _clear_cpanpm_output { $scalar = '' }
+
+sub _get_cpanpm_output { $scalar }
+
+BEGIN {
+my @skip_lines = (
+ qr/^\QWarning \(usually harmless\)/,
+ qr/\bwill not store persistent state\b/,
+ qr(//hint//),
+ qr/^\s+reports\s+/,
+ );
+
+sub _get_cpanpm_last_line
+ {
+ open my($fh), "<", \ $scalar;
+
+ my @lines = <$fh>;
+
+ # This is a bit ugly. Once we examine a line, we have to
+ # examine the line before it and go through all of the same
+ # regexes. I could do something fancy, but this works.
+ REGEXES: {
+ foreach my $regex ( @skip_lines )
+ {
+ if( $lines[-1] =~ m/$regex/ )
+ {
+ pop @lines;
+ redo REGEXES; # we have to go through all of them for every line!
+ }
+ }
+ }
+
+ $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
+
+ $lines[-1];
+ }
+}
+
+BEGIN {
+my $epic_fail_words = join '|',
+ qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? );
+
+sub _cpanpm_output_indicates_failure
+ {
+ my $last_line = _get_cpanpm_last_line();
+
+ my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
+ $result || ();
+ }
+}
+
+sub _cpanpm_output_indicates_success
+ {
+ my $last_line = _get_cpanpm_last_line();
+
+ my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
+ $result || ();
+ }
+
+sub _cpanpm_output_is_vague
+ {
+ return FALSE if
+ _cpanpm_output_indicates_failure() ||
+ _cpanpm_output_indicates_success();
+
+ return TRUE;
+ }
+
+}
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+sub _print_help
+ {
+ $logger->info( "Use perldoc to read the documentation" );
+ exec "perldoc $0";
+ }
+
+sub _print_version
+ {
+ $logger->info(
+ "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
+
+ return HEY_IT_WORKED;
+ }
+
+sub _create_autobundle
+ {
+ $logger->info(
+ "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
+
+ CPAN::Shell->autobundle;
+
+ return HEY_IT_WORKED;
+ }
+
+sub _recompile
+ {
+ $logger->info( "Recompiling dynamically-loaded extensions" );
+
+ CPAN::Shell->recompile;
+
+ return HEY_IT_WORKED;
+ }
+
+sub _upgrade
+ {
+ $logger->info( "Upgrading all modules" );
+
+ CPAN::Shell->upgrade();
+
+ return HEY_IT_WORKED;
+ }
+
+sub _load_config # -j
+ {
+ my $file = shift || '';
+
+ # should I clear out any existing config here?
+ $CPAN::Config = {};
+ delete $INC{'CPAN/Config.pm'};
+ croak( "Config file [$file] does not exist!\n" ) unless -e $file;
+
+ my $rc = eval "require '$file'";
+
+ # CPAN::HandleConfig::require_myconfig_or_config looks for this
+ $INC{'CPAN/MyConfig.pm'} = 'fake out!';
+
+ # CPAN::HandleConfig::load looks for this
+ $CPAN::Config_loaded = 'fake out';
+
+ croak( "Could not load [$file]: $@\n") unless $rc;
+
+ return HEY_IT_WORKED;
+ }
+
+sub _dump_config
+ {
+ my $args = shift;
+ require Data::Dumper;
+
+ my $fh = $args->[0] || \*STDOUT;
+
+ my $dd = Data::Dumper->new(
+ [$CPAN::Config],
+ ['$CPAN::Config']
+ );
+
+ print $fh $dd->Dump, "\n1;\n__END__\n";
+
+ return HEY_IT_WORKED;
+ }
+
+sub _lock_lobotomy
+ {
+ no warnings 'redefine';
+
+ *CPAN::_flock = sub { 1 };
+ *CPAN::checklock = sub { 1 };
+
+ return HEY_IT_WORKED;
+ }
+
+sub _download
+ {
+ my $args = shift;
+
+ local $CPAN::DEBUG = 1;
+
+ my %paths;
+
+ foreach my $module ( @$args )
+ {
+ $logger->info( "Checking $module" );
+ my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+
+ $logger->debug( "Inst file would be $path\n" );
+
+ $paths{$module} = _get_file( _make_path( $path ) );
+ }
+
+ return \%paths;
+ }
+
+sub _make_path { join "/", qw(authors id), $_[0] }
+
+sub _get_file
+ {
+ my $path = shift;
+
+ my $loaded = eval "require LWP::Simple; 1;";
+ croak "You need LWP::Simple to use features that fetch files from CPAN\n"
+ unless $loaded;
+
+ my $file = substr $path, rindex( $path, '/' ) + 1;
+ my $store_path = catfile( cwd(), $file );
+ $logger->debug( "Store path is $store_path" );
+
+ foreach my $site ( @{ $CPAN::Config->{urllist} } )
+ {
+ my $fetch_path = join "/", $site, $path;
+ $logger->debug( "Trying $fetch_path" );
+ last if LWP::Simple::getstore( $fetch_path, $store_path );
+ }
+
+ return $store_path;
+ }
+
+sub _gitify
+ {
+ my $args = shift;
+
+ my $loaded = eval "require Archive::Extract; 1;";
+ croak "You need Archive::Extract to use features that gitify distributions\n"
+ unless $loaded;
+
+ my $starting_dir = cwd();
+
+ foreach my $module ( @$args )
+ {
+ $logger->info( "Checking $module" );
+ my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
+
+ my $store_paths = _download( [ $module ] );
+ $logger->debug( "gitify Store path is $store_paths->{$module}" );
+ my $dirname = dirname( $store_paths->{$module} );
+
+ my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
+ $ae->extract( to => $dirname );
+
+ chdir $ae->extract_path;
+
+ my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
+ croak "Could not find $git" unless -e $git;
+ croak "$git is not executable" unless -x $git;
+
+ # can we do this in Pure Perl?
+ system( $git, 'init' );
+ system( $git, qw( add . ) );
+ system( $git, qw( commit -a -m ), 'initial import' );
+ }
+
+ chdir $starting_dir;
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_Changes
+ {
+ my $args = shift;
+
+ foreach my $arg ( @$args )
+ {
+ $logger->info( "Checking $arg\n" );
+
+ my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
+ my $out = _get_cpanpm_output();
+
+ next unless eval { $module->inst_file };
+ #next if $module->uptodate;
+
+ ( my $id = $module->id() ) =~ s/::/\-/;
+
+ my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
+ $id . "-" . $module->cpan_version() . "/";
+
+ #print "URL: $url\n";
+ _get_changes_file($url);
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _get_changes_file
+ {
+ croak "Reading Changes files requires LWP::Simple and URI\n"
+ unless eval "require LWP::Simple; require URI; 1";
+
+ my $url = shift;
+
+ my $content = LWP::Simple::get( $url );
+ $logger->info( "Got $url ..." ) if defined $content;
+ #print $content;
+
+ my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
+
+ my $changes_url = URI->new_abs( $change_link, $url );
+ $logger->debug( "Change link is: $changes_url" );
+
+ my $changes = LWP::Simple::get( $changes_url );
+
+ print $changes;
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_Author
+ {
+ my $args = shift;
+
+ foreach my $arg ( @$args )
+ {
+ my $module = CPAN::Shell->expand( "Module", $arg );
+ unless( $module )
+ {
+ $logger->info( "Didn't find a $arg module, so no author!" );
+ next;
+ }
+
+ my $author = CPAN::Shell->expand( "Author", $module->userid );
+
+ next unless $module->userid;
+
+ printf "%-25s %-8s %-25s %s\n",
+ $arg, $module->userid, $author->email, $author->fullname;
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_Details
+ {
+ my $args = shift;
+
+ foreach my $arg ( @$args )
+ {
+ my $module = CPAN::Shell->expand( "Module", $arg );
+ my $author = CPAN::Shell->expand( "Author", $module->userid );
+
+ next unless $module->userid;
+
+ print "$arg\n", "-" x 73, "\n\t";
+ print join "\n\t",
+ $module->description ? $module->description : "(no description)",
+ $module->cpan_file,
+ $module->inst_file,
+ 'Installed: ' . $module->inst_version,
+ 'CPAN: ' . $module->cpan_version . ' ' .
+ ($module->uptodate ? "" : "Not ") . "up to date",
+ $author->fullname . " (" . $module->userid . ")",
+ $author->email;
+ print "\n\n";
+
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_out_of_date
+ {
+ my @modules = CPAN::Shell->expand( "Module", "/./" );
+
+ printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
+ print "-" x 73, "\n";
+
+ foreach my $module ( @modules )
+ {
+ next unless $module->inst_file;
+ next if $module->uptodate;
+ printf "%-40s %.4f %.4f\n",
+ $module->id,
+ $module->inst_version ? $module->inst_version : '',
+ $module->cpan_version;
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _show_author_mods
+ {
+ my $args = shift;
+
+ my %hash = map { lc $_, 1 } @$args;
+
+ my @modules = CPAN::Shell->expand( "Module", "/./" );
+
+ foreach my $module ( @modules )
+ {
+ next unless exists $hash{ lc $module->userid };
+ print $module->id, "\n";
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _list_all_mods
+ {
+ require File::Find;
+
+ my $args = shift;
+
+
+ my $fh = \*STDOUT;
+
+ INC: foreach my $inc ( @INC )
+ {
+ my( $wanted, $reporter ) = _generator();
+ File::Find::find( { wanted => $wanted }, $inc );
+
+ my $count = 0;
+ FILE: foreach my $file ( @{ $reporter->() } )
+ {
+ my $version = _parse_version_safely( $file );
+
+ my $module_name = _path_to_module( $inc, $file );
+ next FILE unless defined $module_name;
+
+ print $fh "$module_name\t$version\n";
+
+ #last if $count++ > 5;
+ }
+ }
+
+ return HEY_IT_WORKED;
+ }
+
+sub _generator
+ {
+ my @files = ();
+
+ sub { push @files,
+ File::Spec->canonpath( $File::Find::name )
+ if m/\A\w+\.pm\z/ },
+ sub { \@files },
+ }
+
+sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
+ {
+ my( $file ) = @_;
+
+ local $/ = "\n";
+ local $_; # don't mess with the $_ in the map calling this
+
+ return unless open FILE, "<$file";
+
+ my $in_pod = 0;
+ my $version;
+ while( <FILE> )
+ {
+ chomp;
+ $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
+ next if $in_pod || /^\s*#/;
+
+ next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
+ my( $sigil, $var ) = ( $1, $2 );
+
+ $version = _eval_version( $_, $sigil, $var );
+ last;
+ }
+ close FILE;
+
+ return 'undef' unless defined $version;
+
+ return $version;
+ }
+
+sub _eval_version
+ {
+ my( $line, $sigil, $var ) = @_;
+
+ my $eval = qq{
+ package ExtUtils::MakeMaker::_version;
+
+ local $sigil$var;
+ \$$var=undef; do {
+ $line
+ }; \$$var
+ };
+
+ my $version = do {
+ local $^W = 0;
+ no strict;
+ eval( $eval );
+ };
+
+ return $version;
+ }
+
+sub _path_to_module
+ {
+ my( $inc, $path ) = @_;
+ return if length $path< length $inc;
+
+ my $module_path = substr( $path, length $inc );
+ $module_path =~ s/\.pm\z//;
+
+ # XXX: this is cheating and doesn't handle everything right
+ my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
+ shift @dirs;
+
+ my $module_name = join "::", @dirs;
+
+ return $module_name;
+ }
+
+1;
+
+=back
+
+=head1 EXIT VALUES
+
+The script exits with zero if it thinks that everything worked, or a
+positive number if it thinks that something failed. Note, however, that
+in some cases it has to divine a failure by the output of things it does
+not control. For now, the exit codes are vague:
+
+ 1 An unknown error
+
+ 2 The was an external problem
+
+ 4 There was an internal problem with the script
+
+ 8 A module failed to install
+
+=head1 TO DO
+
+* There is initial support for Log4perl if it is available, but I
+haven't gone through everything to make the NullLogger work out
+correctly if Log4perl is not installed.
+
+* When I capture CPAN.pm output, I need to check for errors and
+report them to the user.
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 SOURCE AVAILABILITY
+
+This code is in Github:
+
+ git://github.com/briandfoy/cpan_script.git
+
+=head1 CREDITS
+
+Japheth Cleaver added the bits to allow a forced install (-f).
+
+Jim Brandt suggest and provided the initial implementation for the
+up-to-date and Changes features.
+
+Adam Kennedy pointed out that exit() causes problems on Windows
+where this script ends up with a .bat extension
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
+
+You may redistribute this under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/App/Prove.pm b/Master/tlpkg/tlperl/lib/App/Prove.pm
new file mode 100644
index 00000000000..fd431ed2f05
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove.pm
@@ -0,0 +1,774 @@
+package App::Prove;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Harness;
+use TAP::Parser::Utils qw( split_shell );
+use File::Spec;
+use Getopt::Long;
+use App::Prove::State;
+use Carp;
+
+=head1 NAME
+
+App::Prove - Implements the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+L<Test::Harness> provides a command, C<prove>, which runs a TAP based
+test suite and prints a report. The C<prove> command is a minimal
+wrapper around an instance of this module.
+
+=head1 SYNOPSIS
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ $app->run;
+
+=cut
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => $^O eq 'VMS';
+use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
+
+use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
+use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
+
+use constant PLUGINS => 'App::Prove::Plugin';
+
+my @ATTR;
+
+BEGIN {
+ @ISA = qw(TAP::Object);
+
+ @ATTR = qw(
+ archive argv blib show_count color directives exec failures comments
+ formatter harness includes modules plugins jobs lib merge parse quiet
+ really_quiet recurse backwards shuffle taint_fail taint_warn timer
+ verbose warnings_fail warnings_warn show_help show_man show_version
+ state_class test_args state dry extension ignore_exit rules state_manager
+ normalize
+ );
+ __PACKAGE__->mk_methods(@ATTR);
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new C<App::Prove>. Optionally a hash ref of attribute
+initializers may be passed.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift || {};
+
+ # setup defaults:
+ for my $key (qw( argv rc_opts includes modules state plugins rules )) {
+ $self->{$key} = [];
+ }
+ $self->{harness_class} = 'TAP::Harness';
+
+ for my $attr (@ATTR) {
+ if ( exists $args->{$attr} ) {
+
+ # TODO: Some validation here
+ $self->{$attr} = $args->{$attr};
+ }
+ }
+
+ my %env_provides_default = (
+ HARNESS_TIMER => 'timer',
+ );
+
+ while ( my ( $env, $attr ) = each %env_provides_default ) {
+ $self->{$attr} = 1 if $ENV{$env};
+ }
+ $self->state_class('App::Prove::State');
+ return $self;
+}
+
+=head3 C<state_class>
+
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.
+
+=head3 C<state_manager>
+
+Getter/setter for the instance of the C<state_class>.
+
+=cut
+
+=head3 C<add_rc_file>
+
+ $prove->add_rc_file('myproj/.proverc');
+
+Called before C<process_args> to prepend the contents of an rc file to
+the options.
+
+=cut
+
+sub add_rc_file {
+ my ( $self, $rc_file ) = @_;
+
+ local *RC;
+ open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
+ while ( defined( my $line = <RC> ) ) {
+ push @{ $self->{rc_opts} },
+ grep { defined and not /^#/ }
+ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
+ }
+ close RC;
+}
+
+=head3 C<process_args>
+
+ $prove->process_args(@args);
+
+Processes the command-line arguments. Attributes will be set
+appropriately. Any filenames may be found in the C<argv> attribute.
+
+Dies on invalid arguments.
+
+=cut
+
+sub process_args {
+ my $self = shift;
+
+ my @rc = RC_FILE;
+ unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
+
+ # Preprocess meta-args.
+ my @args;
+ while ( defined( my $arg = shift ) ) {
+ if ( $arg eq '--norc' ) {
+ @rc = ();
+ }
+ elsif ( $arg eq '--rc' ) {
+ defined( my $rc = shift )
+ or croak "Missing argument to --rc";
+ push @rc, $rc;
+ }
+ elsif ( $arg =~ m{^--rc=(.+)$} ) {
+ push @rc, $1;
+ }
+ else {
+ push @args, $arg;
+ }
+ }
+
+ # Everything after the arisdottle '::' gets passed as args to
+ # test programs.
+ if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
+ my @test_args = splice @args, $stop_at;
+ shift @test_args;
+ $self->{test_args} = \@test_args;
+ }
+
+ # Grab options from RC files
+ $self->add_rc_file($_) for grep -f, @rc;
+ unshift @args, @{ $self->{rc_opts} };
+
+ if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
+ die "Long options should be written with two dashes: ",
+ join( ', ', @bad ), "\n";
+ }
+
+ # And finally...
+
+ {
+ local @ARGV = @args;
+ Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
+
+ # Don't add coderefs to GetOptions
+ GetOptions(
+ 'v|verbose' => \$self->{verbose},
+ 'f|failures' => \$self->{failures},
+ 'o|comments' => \$self->{comments},
+ 'l|lib' => \$self->{lib},
+ 'b|blib' => \$self->{blib},
+ 's|shuffle' => \$self->{shuffle},
+ 'color!' => \$self->{color},
+ 'colour!' => \$self->{color},
+ 'count!' => \$self->{show_count},
+ 'c' => \$self->{color},
+ 'D|dry' => \$self->{dry},
+ 'ext=s' => \$self->{extension},
+ 'harness=s' => \$self->{harness},
+ 'ignore-exit' => \$self->{ignore_exit},
+ 'formatter=s' => \$self->{formatter},
+ 'r|recurse' => \$self->{recurse},
+ 'reverse' => \$self->{backwards},
+ 'p|parse' => \$self->{parse},
+ 'q|quiet' => \$self->{quiet},
+ 'Q|QUIET' => \$self->{really_quiet},
+ 'e|exec=s' => \$self->{exec},
+ 'm|merge' => \$self->{merge},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'P=s@' => $self->{plugins},
+ 'state=s@' => $self->{state},
+ 'directives' => \$self->{directives},
+ 'h|help|?' => \$self->{show_help},
+ 'H|man' => \$self->{show_man},
+ 'V|version' => \$self->{show_version},
+ 'a|archive=s' => \$self->{archive},
+ 'j|jobs=i' => \$self->{jobs},
+ 'timer' => \$self->{timer},
+ 'T' => \$self->{taint_fail},
+ 't' => \$self->{taint_warn},
+ 'W' => \$self->{warnings_fail},
+ 'w' => \$self->{warnings_warn},
+ 'normalize' => \$self->{normalize},
+ 'rules=s@' => $self->{rules},
+ ) or croak('Unable to continue');
+
+ # Stash the remainder of argv for later
+ $self->{argv} = [@ARGV];
+ }
+
+ return;
+}
+
+sub _first_pos {
+ my $want = shift;
+ for ( 0 .. $#_ ) {
+ return $_ if $_[$_] eq $want;
+ }
+ return;
+}
+
+sub _help {
+ my ( $self, $verbosity ) = @_;
+
+ eval('use Pod::Usage 1.12 ()');
+ if ( my $err = $@ ) {
+ die 'Please install Pod::Usage for the --help option '
+ . '(or try `perldoc prove`.)'
+ . "\n ($@)";
+ }
+
+ Pod::Usage::pod2usage( { -verbose => $verbosity } );
+
+ return;
+}
+
+sub _color_default {
+ my $self = shift;
+
+ return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32;
+}
+
+sub _get_args {
+ my $self = shift;
+
+ my %args;
+
+ if ( defined $self->color ? $self->color : $self->_color_default ) {
+ $args{color} = 1;
+ }
+ if ( !defined $self->show_count ) {
+ $args{show_count} = 1;
+ }
+ else {
+ $args{show_count} = $self->show_count;
+ }
+
+ if ( $self->archive ) {
+ $self->require_harness( archive => 'TAP::Harness::Archive' );
+ $args{archive} = $self->archive;
+ }
+
+ if ( my $jobs = $self->jobs ) {
+ $args{jobs} = $jobs;
+ }
+
+ if ( my $harness_opt = $self->harness ) {
+ $self->require_harness( harness => $harness_opt );
+ }
+
+ if ( my $formatter = $self->formatter ) {
+ $args{formatter_class} = $formatter;
+ }
+
+ if ( $self->ignore_exit ) {
+ $args{ignore_exit} = 1;
+ }
+
+ if ( $self->taint_fail && $self->taint_warn ) {
+ die '-t and -T are mutually exclusive';
+ }
+
+ if ( $self->warnings_fail && $self->warnings_warn ) {
+ die '-w and -W are mutually exclusive';
+ }
+
+ for my $a (qw( lib switches )) {
+ my $method = "_get_$a";
+ my $val = $self->$method();
+ $args{$a} = $val if defined $val;
+ }
+
+ # Handle verbose, quiet, really_quiet flags
+ my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
+
+ my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
+ keys %verb_map;
+
+ die "Only one of verbose, quiet or really_quiet should be specified\n"
+ if @verb_adj > 1;
+
+ $args{verbosity} = shift @verb_adj || 0;
+
+ for my $a (qw( merge failures comments timer directives normalize )) {
+ $args{$a} = 1 if $self->$a();
+ }
+
+ $args{errors} = 1 if $self->parse;
+
+ # defined but zero-length exec runs test files as binaries
+ $args{exec} = [ split( /\s+/, $self->exec ) ]
+ if ( defined( $self->exec ) );
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ if ( @{ $self->rules } ) {
+ my @rules;
+ for ( @{ $self->rules } ) {
+ if (/^par=(.*)/) {
+ push @rules, $1;
+ }
+ elsif (/^seq=(.*)/) {
+ push @rules, { seq => $1 };
+ }
+ }
+ $args{rules} = { par => [@rules] };
+ }
+
+ return ( \%args, $self->{harness_class} );
+}
+
+sub _find_module {
+ my ( $self, $class, @search ) = @_;
+
+ croak "Bad module name $class"
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ for my $pfx (@search) {
+ my $name = join( '::', $pfx, $class );
+ eval "require $name";
+ return $name unless $@;
+ }
+
+ eval "require $class";
+ return $class unless $@;
+ return;
+}
+
+sub _load_extension {
+ my ( $self, $name, @search ) = @_;
+
+ my @args = ();
+ if ( $name =~ /^(.*?)=(.*)/ ) {
+ $name = $1;
+ @args = split( /,/, $2 );
+ }
+
+ if ( my $class = $self->_find_module( $name, @search ) ) {
+ $class->import(@args);
+ if ( $class->can('load') ) {
+ $class->load( { app_prove => $self, args => [@args] } );
+ }
+ }
+ else {
+ croak "Can't load module $name";
+ }
+}
+
+sub _load_extensions {
+ my ( $self, $ext, @search ) = @_;
+ $self->_load_extension( $_, @search ) for @$ext;
+}
+
+=head3 C<run>
+
+Perform whatever actions the command line args specified. The C<prove>
+command line tool consists of the following code:
+
+ use App::Prove;
+
+ my $app = App::Prove->new;
+ $app->process_args(@ARGV);
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ unless ( $self->state_manager ) {
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
+ }
+
+ if ( $self->show_help ) {
+ $self->_help(1);
+ }
+ elsif ( $self->show_man ) {
+ $self->_help(2);
+ }
+ elsif ( $self->show_version ) {
+ $self->print_version;
+ }
+ elsif ( $self->dry ) {
+ print "$_\n" for $self->_get_tests;
+ }
+ else {
+
+ $self->_load_extensions( $self->modules );
+ $self->_load_extensions( $self->plugins, PLUGINS );
+
+ local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
+
+ return $self->_runtests( $self->_get_args, $self->_get_tests );
+ }
+
+ return 1;
+}
+
+sub _get_tests {
+ my $self = shift;
+
+ my $state = $self->state_manager;
+ my $ext = $self->extension;
+ $state->extension($ext) if defined $ext;
+ if ( defined( my $state_switch = $self->state ) ) {
+ $state->apply_switch(@$state_switch);
+ }
+
+ my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
+
+ $self->_shuffle(@tests) if $self->shuffle;
+ @tests = reverse @tests if $self->backwards;
+
+ return @tests;
+}
+
+sub _runtests {
+ my ( $self, $args, $harness_class, @tests ) = @_;
+ my $harness = $harness_class->new($args);
+
+ my $state = $self->state_manager;
+
+ $harness->callback(
+ after_test => sub {
+ $state->observe_test(@_);
+ }
+ );
+
+ $harness->callback(
+ after_runtests => sub {
+ $state->commit(@_);
+ }
+ );
+
+ my $aggregator = $harness->runtests(@tests);
+
+ return !$aggregator->has_errors;
+}
+
+sub _get_switches {
+ my $self = shift;
+ my @switches;
+
+ # notes that -T or -t must be at the front of the switches!
+ if ( $self->taint_fail ) {
+ push @switches, '-T';
+ }
+ elsif ( $self->taint_warn ) {
+ push @switches, '-t';
+ }
+ if ( $self->warnings_fail ) {
+ push @switches, '-W';
+ }
+ elsif ( $self->warnings_warn ) {
+ push @switches, '-w';
+ }
+
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
+
+ return @switches ? \@switches : ();
+}
+
+sub _get_lib {
+ my $self = shift;
+ my @libs;
+ if ( $self->lib ) {
+ push @libs, 'lib';
+ }
+ if ( $self->blib ) {
+ push @libs, 'blib/lib', 'blib/arch';
+ }
+ if ( @{ $self->includes } ) {
+ push @libs, @{ $self->includes };
+ }
+
+ #24926
+ @libs = map { File::Spec->rel2abs($_) } @libs;
+
+ # Huh?
+ return @libs ? \@libs : ();
+}
+
+sub _shuffle {
+ my $self = shift;
+
+ # Fisher-Yates shuffle
+ my $i = @_;
+ while ($i) {
+ my $j = rand $i--;
+ @_[ $i, $j ] = @_[ $j, $i ];
+ }
+ return;
+}
+
+=head3 C<require_harness>
+
+Load a harness replacement class.
+
+ $prove->require_harness($for => $class_name);
+
+=cut
+
+sub require_harness {
+ my ( $self, $for, $class ) = @_;
+
+ my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
+
+ # Emulate Perl's -MModule=arg1,arg2 behaviour
+ $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
+
+ eval("use $class;");
+ die "$class_name is required to use the --$for feature: $@" if $@;
+
+ $self->{harness_class} = $class_name;
+
+ return;
+}
+
+=head3 C<print_version>
+
+Display the version numbers of the loaded L<TAP::Harness> and the
+current Perl.
+
+=cut
+
+sub print_version {
+ my $self = shift;
+ printf(
+ "TAP::Harness v%s and Perl v%vd\n",
+ $TAP::Harness::VERSION, $^V
+ );
+
+ return;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+
+=head2 Attributes
+
+After command line parsing the following attributes reflect the values
+of the corresponding command line switches. They may be altered before
+calling C<run>.
+
+=over
+
+=item C<archive>
+
+=item C<argv>
+
+=item C<backwards>
+
+=item C<blib>
+
+=item C<color>
+
+=item C<directives>
+
+=item C<dry>
+
+=item C<exec>
+
+=item C<extension>
+
+=item C<failures>
+
+=item C<comments>
+
+=item C<formatter>
+
+=item C<harness>
+
+=item C<ignore_exit>
+
+=item C<includes>
+
+=item C<jobs>
+
+=item C<lib>
+
+=item C<merge>
+
+=item C<modules>
+
+=item C<parse>
+
+=item C<plugins>
+
+=item C<quiet>
+
+=item C<really_quiet>
+
+=item C<recurse>
+
+=item C<rules>
+
+=item C<show_count>
+
+=item C<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=item C<state_class>
+
+=item C<taint_fail>
+
+=item C<taint_warn>
+
+=item C<test_args>
+
+=item C<timer>
+
+=item C<verbose>
+
+=item C<warnings_fail>
+
+=item C<warnings_warn>
+
+=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass an argument to your plugin by appending an C<=> after the plugin
+name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
+
+ prove -PMyPlugin=foo,bar,baz
+
+These are passed in to your plugin's C<load()> class method (if it has one),
+along with a reference to the C<App::Prove> object that is invoking your plugin:
+
+ sub load {
+ my ($class, $p) = @_;
+
+ my @args = @{ $p->{args} };
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ $p->{app_prove}->do_something;
+ ...
+ }
+
+Note that the user's arguments are also passed to your plugin's C<import()>
+function as a list, eg:
+
+ sub import {
+ my ($class, @args) = @_;
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ ...
+ }
+
+This is for backwards compatibility, and may be deprecated in the future.
+
+=head2 Sample Plugin
+
+Here's a sample plugin, for your reference:
+
+ package App::Prove::Plugin::Foo;
+
+ # Sample plugin, try running with:
+ # prove -PFoo=bar -r -j3
+ # prove -PFoo -Q
+ # prove -PFoo=bar,My::Formatter
+
+ use strict;
+ use warnings;
+
+ sub load {
+ my ($class, $p) = @_;
+ my @args = @{ $p->{args} };
+ my $app = $p->{app_prove};
+
+ print "loading plugin: $class, args: ", join(', ', @args ), "\n";
+
+ # turn on verbosity
+ $app->verbose( 1 );
+
+ # set the formatter?
+ $app->formatter( $args[1] ) if @args > 1;
+
+ # print some of App::Prove's state:
+ for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
+ my $val = $app->$attr;
+ $val = 'undef' unless defined( $val );
+ print "$attr: $val\n";
+ }
+
+ return 1;
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<prove>, L<TAP::Harness>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State.pm b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
new file mode 100644
index 00000000000..202f7aadd3b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
@@ -0,0 +1,517 @@
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+
+use App::Prove::State::Result;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __PACKAGE__->mk_methods('result_class');
+}
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant NEED_GLOB => IS_WIN32;
+
+=head1 NAME
+
+App::Prove::State - State storage for the C<prove> command.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module implements that state
+and the operations that may be performed on it.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => ( delete $args{extension} || '.t' ),
+ result_class =>
+ ( delete $args{result_class} || 'App::Prove::State::Result' ),
+ }, $class;
+
+ $self->{_} = $self->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ );
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=head2 C<result_class>
+
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
+identical interface.
+
+=cut
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new;
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
+ my $self = shift;
+ if ( $self->{should_save} ) {
+ $self->save;
+ }
+}
+
+=head2 Instance Methods
+
+=head3 C<apply_switch>
+
+ $self->apply_switch('failed,save');
+
+Apply a list of switch options to the state, updating the internal
+object state as a result. Nothing is returned.
+
+Diagnostics:
+ - "Illegal state option: %s"
+
+=over
+
+=item C<last>
+
+Run in the same order as last time
+
+=item C<failed>
+
+Run only the failed tests from last time
+
+=item C<passed>
+
+Run only the passed tests from last time
+
+=item C<all>
+
+Run all tests in normal order
+
+=item C<hot>
+
+Run the tests that most recently failed first
+
+=item C<todo>
+
+Run the tests ordered by number of todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order.
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<save>
+
+Save the state on exit.
+
+=back
+
+=cut
+
+sub apply_switch {
+ my $self = shift;
+ my @opts = @_;
+
+ my $last_gen = $self->results->generation - 1;
+ my $last_run_time = $self->results->last_run_time;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->result == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->elapsed } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->elapsed } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->mtime } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
+ },
+ save => sub {
+ $self->{should_save}++;
+ },
+ adrian => sub {
+ unshift @switches, qw( hot all save );
+ },
+ );
+
+ while ( defined( my $ele = shift @switches ) ) {
+ my ( $opt, $arg )
+ = ( $ele =~ /^([^:]+):(.*)/ )
+ ? ( $1, $2 )
+ : ( $ele, undef );
+ my $code = $handler{$opt}
+ || croak "Illegal state option: $opt";
+ $code->($arg);
+ }
+ return;
+}
+
+sub _select {
+ my ( $self, %spec ) = @_;
+ push @{ $self->{select} }, \%spec;
+}
+
+=head3 C<get_tests>
+
+Given a list of args get the names of tests that should run
+
+=cut
+
+sub get_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my %seen;
+
+ my @selected = $self->_query;
+
+ unless ( @argv || @{ $self->{select} } ) {
+ @argv = $recurse ? '.' : 't';
+ croak qq{No tests named and '@argv' directory not found}
+ unless -d $argv[0];
+ }
+
+ push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
+ return grep { !$seen{$_}++ } @selected;
+}
+
+sub _query {
+ my $self = shift;
+ if ( my @sel = @{ $self->{select} } ) {
+ warn "No saved state, selection will be empty\n"
+ unless $self->results->num_tests;
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $results = $self->results;
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $name ( $results->test_names ) {
+ next unless -f $name;
+ local $_ = $results->test($name);
+ push @got, $name if $where->();
+ }
+
+ # Sort
+ if ( my $order = $clause->{order} ) {
+ @got = map { $_->[0] }
+ sort {
+ ( defined $b->[1] <=> defined $a->[1] )
+ || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
+ } map {
+ [ $_,
+ do { local $_ = $results->test($_); $order->() }
+ ]
+ } @got;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ follow_skip => 2,
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && push @tests => $File::Find::name;
+ }
+ },
+ $dir
+ );
+ return @tests;
+}
+
+=head3 C<observe_test>
+
+Store the results of a test.
+
+=cut
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+# parser
+
+sub observe_test {
+
+ my ( $self, $test_info, $parser ) = @_;
+ my $name = $test_info->[0];
+ my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
+ my $todo = scalar( $parser->todo );
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time,
+
+ my $test = $self->results->test($name);
+
+ $test->sequence( $self->{seq}++ );
+ $test->generation( $self->results->generation );
+
+ $test->run_time($end_time);
+ $test->result($fail);
+ $test->num_todo($todo);
+ $test->elapsed( $end_time - $start_time );
+
+ $test->parser($parser);
+
+ if ($fail) {
+ $test->total_failures( $test->total_failures + 1 );
+ $test->last_fail_time($end_time);
+ }
+ else {
+ $test->total_passes( $test->total_passes + 1 );
+ $test->last_pass_time($end_time);
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ($self) = @_;
+
+ my $store = $self->{store} or return;
+ $self->results->last_run_time( $self->get_time );
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$store" or croak "Can't write $store ($!)";
+ $writer->write( $self->results->raw, \*FH );
+ close FH;
+}
+
+=head3 C<load>
+
+Load the state from a file
+
+=cut
+
+sub load {
+ my ( $self, $name ) = @_;
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+ local *FH;
+ open FH, "<$name" or croak "Can't read $name ($!)";
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
+ );
+
+ # $writer->write( $self->{tests} || {}, \*FH );
+ close FH;
+ $self->_regen_seq;
+ $self->_prune_and_stamp;
+ $self->results->generation( $self->results->generation + 1 );
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
+ if ( my @stat = stat $name ) {
+ $test->mtime( $stat[9] );
+ }
+ else {
+ $results->remove($name);
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
new file mode 100644
index 00000000000..274676a62f9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
@@ -0,0 +1,233 @@
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new( { name => $name } );
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
new file mode 100644
index 00000000000..231f78919e2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
@@ -0,0 +1,153 @@
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+ parser => { method => 'parser' },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=head3 C<parser>
+
+The underlying parser object. This is useful if you need the full
+information for the test program.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not guaranteed.
+ delete $raw{name};
+ delete $raw{parser};
+ return \%raw;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
new file mode 100644
index 00000000000..08676fb1e08
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Extract.pm
@@ -0,0 +1,1511 @@
+package Archive::Extract;
+
+use strict;
+
+use Cwd qw[cwd chdir];
+use Carp qw[carp];
+use IPC::Cmd qw[run can_run];
+use FileHandle;
+use File::Path qw[mkpath];
+use File::Spec;
+use File::Basename qw[dirname basename];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load check_install];
+use Locale::Maketext::Simple Style => 'gettext';
+
+### solaris has silly /bin/tar output ###
+use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0;
+use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
+
+### VMS may require quoting upper case command options
+use constant ON_VMS => $^O eq 'VMS' ? 1 : 0;
+
+### Windows needs special treatment of Tar options
+use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+
+### we can't use this extraction method, because of missing
+### modules/binaries:
+use constant METHOD_NA => [];
+
+### If these are changed, update @TYPES and the new() POD
+use constant TGZ => 'tgz';
+use constant TAR => 'tar';
+use constant GZ => 'gz';
+use constant ZIP => 'zip';
+use constant BZ2 => 'bz2';
+use constant TBZ => 'tbz';
+use constant Z => 'Z';
+use constant LZMA => 'lzma';
+
+use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
+ $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
+ ];
+
+$VERSION = '0.38';
+$PREFER_BIN = 0;
+$WARN = 1;
+$DEBUG = 0;
+$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
+$_ALLOW_BIN = 1; # allow binary extractors
+$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available
+
+# same as all constants
+my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA );
+
+local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+Archive::Extract - A generic archive extracting mechanism
+
+=head1 SYNOPSIS
+
+ use Archive::Extract;
+
+ ### build an Archive::Extract object ###
+ my $ae = Archive::Extract->new( archive => 'foo.tgz' );
+
+ ### extract to cwd() ###
+ my $ok = $ae->extract;
+
+ ### extract to /tmp ###
+ my $ok = $ae->extract( to => '/tmp' );
+
+ ### what if something went wrong?
+ my $ok = $ae->extract or die $ae->error;
+
+ ### files from the archive ###
+ my $files = $ae->files;
+
+ ### dir that was extracted to ###
+ my $outdir = $ae->extract_path;
+
+
+ ### quick check methods ###
+ $ae->is_tar # is it a .tar file?
+ $ae->is_tgz # is it a .tar.gz or .tgz file?
+ $ae->is_gz; # is it a .gz file?
+ $ae->is_zip; # is it a .zip file?
+ $ae->is_bz2; # is it a .bz2 file?
+ $ae->is_tbz; # is it a .tar.bz2 or .tbz file?
+ $ae->is_lzma; # is it a .lzma file?
+
+ ### absolute path to the archive you provided ###
+ $ae->archive;
+
+ ### commandline tools, if found ###
+ $ae->bin_tar # path to /bin/tar, if found
+ $ae->bin_gzip # path to /bin/gzip, if found
+ $ae->bin_unzip # path to /bin/unzip, if found
+ $ae->bin_bunzip2 # path to /bin/bunzip2 if found
+ $ae->bin_unlzma # path to /bin/unlzma if found
+
+=head1 DESCRIPTION
+
+Archive::Extract is a generic archive extraction mechanism.
+
+It allows you to extract any archive file of the type .tar, .tar.gz,
+.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it
+does so, or use different interfaces for each type by using either
+perl modules, or commandline tools on your system.
+
+See the C<HOW IT WORKS> section further down for details.
+
+=cut
+
+
+### see what /bin/programs are available ###
+$PROGRAMS = {};
+for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) {
+ $PROGRAMS->{$pgm} = can_run($pgm);
+}
+
+### mapping from types to extractor methods ###
+my $Mapping = { # binary program # pure perl module
+ is_tgz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_tar => { bin => '_untar_bin', pp => '_untar_at' },
+ is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' },
+ is_zip => { bin => '_unzip_bin', pp => '_unzip_az' },
+ is_tbz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'},
+ is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' },
+ is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' },
+};
+
+{ ### use subs so we re-generate array refs etc for the no-overide flags
+ ### if we don't, then we reuse the same arrayref, meaning objects store
+ ### previous errors
+ my $tmpl = {
+ archive => sub { { required => 1, allow => FILE_EXISTS } },
+ type => sub { { default => '', allow => [ @Types ] } },
+ _error_msg => sub { { no_override => 1, default => [] } },
+ _error_msg_long => sub { { no_override => 1, default => [] } },
+ };
+
+ ### build accesssors ###
+ for my $method( keys %$tmpl,
+ qw[_extractor _gunzip_to files extract_path],
+ ) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method} = $_[0] if @_;
+ return $self->{$method};
+ }
+ }
+
+=head1 METHODS
+
+=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE])
+
+Creates a new C<Archive::Extract> object based on the archive file you
+passed it. Automatically determines the type of archive based on the
+extension, but you can override that by explicitly providing the
+C<type> argument.
+
+Valid values for C<type> are:
+
+=over 4
+
+=item tar
+
+Standard tar files, as produced by, for example, C</bin/tar>.
+Corresponds to a C<.tar> suffix.
+
+=item tgz
+
+Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
+Corresponds to a C<.tgz> or C<.tar.gz> suffix.
+
+=item gz
+
+Gzip compressed file, as produced by, for example C</bin/gzip>.
+Corresponds to a C<.gz> suffix.
+
+=item Z
+
+Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
+Corresponds to a C<.Z> suffix.
+
+=item zip
+
+Zip compressed file, as produced by, for example C</bin/zip>.
+Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
+
+=item bz2
+
+Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
+Corresponds to a C<.bz2> suffix.
+
+=item tbz
+
+Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
+Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
+
+=item lzma
+
+Lzma compressed file, as produced by C</bin/lzma>.
+Corresponds to a C<.lzma> suffix.
+
+=back
+
+Returns a C<Archive::Extract> object on success, or false on failure.
+
+=cut
+
+ ### constructor ###
+ sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### see above why we use subs here and generate the template;
+ ### it's basically to not re-use arrayrefs
+ my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl;
+
+ my $parsed = check( \%utmpl, \%hash ) or return;
+
+ ### make sure we have an absolute path ###
+ my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
+
+ ### figure out the type, if it wasn't already specified ###
+ unless ( $parsed->{type} ) {
+ $parsed->{type} =
+ $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
+ $ar =~ /.+?\.gz$/i ? GZ :
+ $ar =~ /.+?\.tar$/i ? TAR :
+ $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
+ $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
+ $ar =~ /.+?\.bz2$/i ? BZ2 :
+ $ar =~ /.+?\.Z$/ ? Z :
+ $ar =~ /.+?\.lzma$/ ? LZMA :
+ '';
+
+ }
+
+ bless $parsed, $class;
+
+ ### don't know what type of file it is
+ ### XXX this *has* to be an object call, not a package call
+ return $parsed->_error(loc("Cannot determine file type for '%1'",
+ $parsed->{archive} )) unless $parsed->{type};
+ return $parsed;
+ }
+}
+
+=head2 $ae->extract( [to => '/output/path'] )
+
+Extracts the archive represented by the C<Archive::Extract> object to
+the path of your choice as specified by the C<to> argument. Defaults to
+C<cwd()>.
+
+Since C<.gz> files never hold a directory, but only a single file; if
+the C<to> argument is an existing directory, the file is extracted
+there, with its C<.gz> suffix stripped.
+If the C<to> argument is not an existing directory, the C<to> argument
+is understood to be a filename, if the archive type is C<gz>.
+In the case that you did not specify a C<to> argument, the output
+file will be the name of the archive file, stripped from its C<.gz>
+suffix, in the current working directory.
+
+C<extract> will try a pure perl solution first, and then fall back to
+commandline tools if they are available. See the C<GLOBAL VARIABLES>
+section below on how to alter this behaviour.
+
+It will return true on success, and false on failure.
+
+On success, it will also set the follow attributes in the object:
+
+=over 4
+
+=item $ae->extract_path
+
+This is the directory that the files where extracted to.
+
+=item $ae->files
+
+This is an array ref with the paths of all the files in the archive,
+relative to the C<to> argument you specified.
+To get the full path to an extracted file, you would use:
+
+ File::Spec->catfile( $to, $ae->files->[0] );
+
+Note that all files from a tar archive will be in unix format, as per
+the tar specification.
+
+=back
+
+=cut
+
+sub extract {
+ my $self = shift;
+ my %hash = @_;
+
+ ### reset error messages
+ $self->_error_msg( [] );
+ $self->_error_msg_long( [] );
+
+ my $to;
+ my $tmpl = {
+ to => { default => '.', store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### so 'to' could be a file or a dir, depending on whether it's a .gz
+ ### file, or basically anything else.
+ ### so, check that, then act accordingly.
+ ### set an accessor specifically so _gunzip can know what file to extract
+ ### to.
+ my $dir;
+ { ### a foo.gz file
+ if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) {
+
+ my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i;
+
+ ### to is a dir?
+ if ( -d $to ) {
+ $dir = $to;
+ $self->_gunzip_to( basename($cp) );
+
+ ### then it's a filename
+ } else {
+ $dir = dirname($to);
+ $self->_gunzip_to( basename($to) );
+ }
+
+ ### not a foo.gz file
+ } else {
+ $dir = $to;
+ }
+ }
+
+ ### make the dir if it doesn't exist ###
+ unless( -d $dir ) {
+ eval { mkpath( $dir ) };
+
+ return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
+ if $@;
+ }
+
+ ### get the current dir, to restore later ###
+ my $cwd = cwd();
+
+ my $ok = 1;
+ EXTRACT: {
+
+ ### chdir to the target dir ###
+ unless( chdir $dir ) {
+ $self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
+ $ok = 0; last EXTRACT;
+ }
+
+ ### set files to an empty array ref, so there's always an array
+ ### ref IN the accessor, to avoid errors like:
+ ### Can't use an undefined value as an ARRAY reference at
+ ### ../lib/Archive/Extract.pm line 742. (rt #19815)
+ $self->files( [] );
+
+ ### find out the dispatch methods needed for this type of
+ ### archive. Do a $self->is_XXX to figure out the type, then
+ ### get the hashref with bin + pure perl dispatchers.
+ my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;
+
+ ### add pure perl extractor if allowed & add bin extractor if allowed
+ my @methods;
+ push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL;
+ push @methods, $map->{'bin'} if $_ALLOW_BIN;
+
+ ### reverse it if we prefer bin extractors
+ @methods = reverse @methods if $PREFER_BIN;
+
+ my($na, $fail);
+ for my $method (@methods) {
+ print "# Extracting with ->$method\n" if $DEBUG;
+
+ my $rv = $self->$method;
+
+ ### a positive extraction
+ if( $rv and $rv ne METHOD_NA ) {
+ print "# Extraction succeeded\n" if $DEBUG;
+ $self->_extractor($method);
+ last;
+
+ ### method is not available
+ } elsif ( $rv and $rv eq METHOD_NA ) {
+ print "# Extraction method not available\n" if $DEBUG;
+ $na++;
+ } else {
+ print "# Extraction method failed\n" if $DEBUG;
+ $fail++;
+ }
+ }
+
+ ### warn something went wrong if we didn't get an extractor
+ unless( $self->_extractor ) {
+ my $diag = $fail ? loc("Extract failed due to errors") :
+ $na ? loc("Extract failed; no extractors available") :
+ '';
+
+ $self->_error($diag);
+ $ok = 0;
+ }
+ }
+
+ ### and chdir back ###
+ unless( chdir $cwd ) {
+ $self->_error(loc("Could not chdir back to start dir '%1': %2'",
+ $cwd, $!));
+ }
+
+ return $ok;
+}
+
+=pod
+
+=head1 ACCESSORS
+
+=head2 $ae->error([BOOL])
+
+Returns the last encountered error as string.
+Pass it a true value to get the C<Carp::longmess()> output instead.
+
+=head2 $ae->extract_path
+
+This is the directory the archive got extracted to.
+See C<extract()> for details.
+
+=head2 $ae->files
+
+This is an array ref holding all the paths from the archive.
+See C<extract()> for details.
+
+=head2 $ae->archive
+
+This is the full path to the archive file represented by this
+C<Archive::Extract> object.
+
+=head2 $ae->type
+
+This is the type of archive represented by this C<Archive::Extract>
+object. See accessors below for an easier way to use this.
+See the C<new()> method for details.
+
+=head2 $ae->types
+
+Returns a list of all known C<types> for C<Archive::Extract>'s
+C<new> method.
+
+=cut
+
+sub types { return @Types }
+
+=head2 $ae->is_tgz
+
+Returns true if the file is of type C<.tar.gz>.
+See the C<new()> method for details.
+
+=head2 $ae->is_tar
+
+Returns true if the file is of type C<.tar>.
+See the C<new()> method for details.
+
+=head2 $ae->is_gz
+
+Returns true if the file is of type C<.gz>.
+See the C<new()> method for details.
+
+=head2 $ae->is_Z
+
+Returns true if the file is of type C<.Z>.
+See the C<new()> method for details.
+
+=head2 $ae->is_zip
+
+Returns true if the file is of type C<.zip>.
+See the C<new()> method for details.
+
+=head2 $ae->is_lzma
+
+Returns true if the file is of type C<.lzma>.
+See the C<new()> method for details.
+
+=cut
+
+### quick check methods ###
+sub is_tgz { return $_[0]->type eq TGZ }
+sub is_tar { return $_[0]->type eq TAR }
+sub is_gz { return $_[0]->type eq GZ }
+sub is_zip { return $_[0]->type eq ZIP }
+sub is_tbz { return $_[0]->type eq TBZ }
+sub is_bz2 { return $_[0]->type eq BZ2 }
+sub is_Z { return $_[0]->type eq Z }
+sub is_lzma { return $_[0]->type eq LZMA }
+
+=pod
+
+=head2 $ae->bin_tar
+
+Returns the full path to your tar binary, if found.
+
+=head2 $ae->bin_gzip
+
+Returns the full path to your gzip binary, if found
+
+=head2 $ae->bin_unzip
+
+Returns the full path to your unzip binary, if found
+
+=head2 $ae->bin_unlzma
+
+Returns the full path to your unlzma binary, if found
+
+=cut
+
+### paths to commandline tools ###
+sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} }
+sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} }
+sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} }
+sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
+sub bin_uncompress { return $PROGRAMS->{'uncompress'}
+ if $PROGRAMS->{'uncompress'} }
+sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} }
+
+=head2 $bool = $ae->have_old_bunzip2
+
+Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
+require all archive names to end in C<.bz2> or it will not extract
+them. This method checks if you have a recent version of C<bunzip2>
+that allows any extension, or an older one that doesn't.
+
+=cut
+
+sub have_old_bunzip2 {
+ my $self = shift;
+
+ ### no bunzip2? no old bunzip2 either :)
+ return unless $self->bin_bunzip2;
+
+ ### if we can't run this, we can't be sure if it's too old or not
+ ### XXX stupid stupid stupid bunzip2 doesn't understand --version
+ ### is not a request to extract data:
+ ### $ bunzip2 --version
+ ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001.
+ ### [...]
+ ### bunzip2: I won't read compressed data from a terminal.
+ ### bunzip2: For help, type: `bunzip2 --help'.
+ ### $ echo $?
+ ### 1
+ ### HATEFUL!
+
+ ### double hateful: bunzip2 --version also hangs if input is a pipe
+ ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH]
+ ### So, we have to provide *another* argument which is a fake filename,
+ ### just so it wont try to read from stdin to print its version..
+ ### *sigh*
+ ### Even if the file exists, it won't clobber or change it.
+ my $buffer;
+ scalar run(
+ command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
+ verbose => 0,
+ buffer => \$buffer
+ );
+
+ ### no output
+ return unless $buffer;
+
+ my ($version) = $buffer =~ /version \s+ (\d+)/ix;
+
+ return 1 if $version < 1;
+ return;
+}
+
+#################################
+#
+# Untar code
+#
+#################################
+
+### annoying issue with (gnu) tar on win32, as illustrated by this
+### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
+### which shows that (gnu) tar will interpret a file name with a :
+### in it as a remote file name, so C:\tmp\foo.txt is interpreted
+### as a remote shell, and the extract fails.
+{ my @ExtraTarFlags;
+ if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {
+
+ ### if this is gnu tar we are running, we need to use --force-local
+ push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
+ }
+
+
+ ### use /bin/tar to extract ###
+ sub _untar_bin {
+ my $self = shift;
+
+ ### check for /bin/tar ###
+ ### check for /bin/gzip if we need it ###
+ ### if any of the binaries are not available, return NA
+ { my $diag = not $self->bin_tar ?
+ loc("No '%1' program found", '/bin/tar') :
+ $self->is_tgz && !$self->bin_gzip ?
+ loc("No '%1' program found", '/bin/gzip') :
+ $self->is_tbz && !$self->bin_bunzip2 ?
+ loc("No '%1' program found", '/bin/bunzip2') :
+ '';
+
+ if( $diag ) {
+ $self->_error( $diag );
+ return METHOD_NA;
+ }
+ }
+
+ ### XXX figure out how to make IPC::Run do this in one call --
+ ### currently i don't know how to get output of a command after a pipe
+ ### trapped in a scalar. Mailed barries about this 5th of june 2004.
+
+ ### see what command we should run, based on whether
+ ### it's a .tgz or .tar
+
+ ### XXX solaris tar and bsdtar are having different outputs
+ ### depending whether you run with -x or -t
+ ### compensate for this insanity by running -t first, then -x
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ $self->bin_tar, '-tf', '-'] :
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->bin_tar, '-tf', '-'] :
+ [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive];
+
+ ### run the command
+ ### newer versions of 'tar' (1.21 and up) now print record size
+ ### to STDERR as well if v OR t is given (used to be both). This
+ ### is a 'feature' according to the changelog, so we must now only
+ ### inspect STDOUT, otherwise, failures like these occur:
+ ### nntp.perl.org/group/perl.cpan.testers/2009/02/msg3230366.html
+ my $buffer = '';
+ my @out = run( command => $cmd,
+ buffer => \$buffer,
+ verbose => $DEBUG );
+
+ ### command was unsuccessful
+ unless( $out[0] ) {
+ return $self->_error(loc(
+ "Error listing contents of archive '%1': %2",
+ $self->archive, $buffer ));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_files( $self->archive ) );
+
+ } else {
+ ### if we're on solaris we /might/ be using /bin/tar, which has
+ ### a weird output format... we might also be using
+ ### /usr/local/bin/tar, which is gnu tar, which is perfectly
+ ### fine... so we have to do some guessing here =/
+ my @files = map { chomp;
+ !ON_SOLARIS ? $_
+ : (m|^ x \s+ # 'xtract' -- sigh
+ (.+?), # the actual file name
+ \s+ [\d,.]+ \s bytes,
+ \s+ [\d,.]+ \s tape \s blocks
+ |x ? $1 : $_);
+
+ ### only STDOUT, see above. Sometims, extra whitespace
+ ### is present, so make sure we only pick lines with
+ ### a length
+ } grep { length } map { split $/, $_ } @{$out[3]};
+
+ ### store the files that are in the archive ###
+ $self->files(\@files);
+ }
+ }
+
+ ### now actually extract it ###
+ { my $cmd =
+ $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
+ $self->bin_tar, '-xf', '-'] :
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
+ $self->bin_tar, '-xf', '-'] :
+ [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive];
+
+ my $buffer = '';
+ unless( scalar run( command => $cmd,
+ buffer => \$buffer,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Error extracting archive '%1': %2",
+ $self->archive, $buffer ));
+ }
+
+ ### we might not have them, due to lack of buffers
+ if( $self->files ) {
+ ### now that we've extracted, figure out where we extracted to
+ my $dir = $self->__get_extract_dir( $self->files );
+
+ ### store the extraction dir ###
+ $self->extract_path( $dir );
+ }
+ }
+
+ ### we got here, no error happened
+ return 1;
+ }
+}
+
+
+### use archive::tar to extract ###
+sub _untar_at {
+ my $self = shift;
+
+ ### Loading Archive::Tar is going to set it to 1, so make it local
+ ### within this block, starting with its initial value. Whatever
+ ### Achive::Tar does will be undone when we return.
+ ###
+ ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
+ ### so users don't have to even think about this variable. If they
+ ### do, they still get their set value outside of this call.
+ local $Archive::Tar::WARN = $Archive::Tar::WARN;
+
+ ### we definitely need Archive::Tar, so load that first
+ { my $use_list = { 'Archive::Tar' => '0.0' };
+
+ unless( can_load( modules => $use_list ) ) {
+
+ $self->_error(loc("You do not have '%1' installed - " .
+ "Please install it as soon as possible.",
+ 'Archive::Tar'));
+
+ return METHOD_NA;
+ }
+ }
+
+ ### we might pass it a filehandle if it's a .tbz file..
+ my $fh_to_read = $self->archive;
+
+ ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
+ ### if A::T's version is 0.99 or higher
+ if( $self->is_tgz ) {
+ my $use_list = { 'Compress::Zlib' => '0.0' };
+ $use_list->{ 'IO::Zlib' } = '0.0'
+ if $Archive::Tar::VERSION >= '0.99';
+
+ unless( can_load( modules => $use_list ) ) {
+ my $which = join '/', sort keys %$use_list;
+
+ $self->_error(loc(
+ "You do not have '%1' installed - Please ".
+ "install it as soon as possible.", $which)
+ );
+
+ return METHOD_NA;
+ }
+
+ } elsif ( $self->is_tbz ) {
+ my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc(
+ "You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2')
+ );
+
+ return METHOD_NA;
+ }
+
+ my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
+ return $self->_error(loc("Unable to open '%1': %2",
+ $self->archive,
+ $IO::Uncompress::Bunzip2::Bunzip2Error));
+
+ $fh_to_read = $bz;
+ }
+
+ my @files;
+ {
+ ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
+ ### localized $Archive::Tar::WARN already.
+ $Archive::Tar::WARN = $Archive::Extract::WARN;
+
+ ### only tell it it's compressed if it's a .tgz, as we give it a file
+ ### handle if it's a .tbz
+ my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );
+
+ ### for version of Archive::Tar > 1.04
+ local $Archive::Tar::CHOWN = 0;
+
+ ### use the iterator if we can. it's a feature of A::T 1.40 and up
+ if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {
+
+ my $next;
+ unless ( $next = Archive::Tar->iter( @read ) ) {
+ return $self->_error(loc(
+ "Unable to read '%1': %2", $self->archive,
+ $Archive::Tar::error));
+ }
+
+ while ( my $file = $next->() ) {
+ push @files, $file->full_path;
+
+ $file->extract or return $self->_error(loc(
+ "Unable to read '%1': %2",
+ $self->archive,
+ $Archive::Tar::error));
+ }
+
+ ### older version, read the archive into memory
+ } else {
+
+ my $tar = Archive::Tar->new();
+
+ unless( $tar->read( @read ) ) {
+ return $self->_error(loc("Unable to read '%1': %2",
+ $self->archive, $Archive::Tar::error));
+ }
+
+ ### workaround to prevent Archive::Tar from setting uid, which
+ ### is a potential security hole. -autrijus
+ ### have to do it here, since A::T needs to be /loaded/ first ###
+ { no strict 'refs'; local $^W;
+
+ ### older versions of archive::tar <= 0.23
+ *Archive::Tar::chown = sub {};
+ }
+
+ { local $^W; # quell 'splice() offset past end of array' warnings
+ # on older versions of A::T
+
+ ### older archive::tar always returns $self, return value
+ ### slightly fux0r3d because of it.
+ $tar->extract or return $self->_error(loc(
+ "Unable to extract '%1': %2",
+ $self->archive, $Archive::Tar::error ));
+ }
+
+ @files = $tar->list_files;
+ }
+ }
+
+ my $dir = $self->__get_extract_dir( \@files );
+
+ ### store the files that are in the archive ###
+ $self->files(\@files);
+
+ ### store the extraction dir ###
+ $self->extract_path( $dir );
+
+ ### check if the dir actually appeared ###
+ return 1 if -d $self->extract_path;
+
+ ### no dir, we failed ###
+ return $self->_error(loc("Unable to extract '%1': %2",
+ $self->archive, $Archive::Tar::error ));
+}
+
+#################################
+#
+# Gunzip code
+#
+#################################
+
+sub _gunzip_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_gzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/gzip'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to gunzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+sub _gunzip_cz {
+ my $self = shift;
+
+ my $use_list = { 'Compress::Zlib' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::Zlib'));
+ return METHOD_NA;
+ }
+
+ my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
+ return $self->_error(loc("Unable to open '%1': %2",
+ $self->archive, $Compress::Zlib::gzerrno));
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $buffer;
+ $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0;
+ $fh->close;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+#################################
+#
+# Uncompress code
+#
+#################################
+
+sub _uncompress_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_uncompress ) {
+ $self->_error(loc("No '%1' program found", '/bin/uncompress'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_uncompress, '-c', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to uncompress '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+
+#################################
+#
+# Unzip code
+#
+#################################
+
+
+sub _unzip_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip if we need it ###
+ unless( $self->bin_unzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/unzip'));
+ return METHOD_NA;
+ }
+
+ ### first, get the files.. it must be 2 different commands with 'unzip' :(
+ { ### on VMS, capital letter options have to be quoted. This is
+ ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
+ ### Subject: [patch@31735]Archive Extract fix on VMS.
+ my $opt = ON_VMS ? '"-Z"' : '-Z';
+ my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
+
+ my $buffer = '';
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_files( $self->archive ) );
+
+ } else {
+ $self->files( [split $/, $buffer] );
+ }
+ }
+
+ ### now, extract the archive ###
+ { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unzip '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ if( scalar @{$self->files} ) {
+ my $files = $self->files;
+ my $dir = $self->__get_extract_dir( $files );
+
+ $self->extract_path( $dir );
+ }
+ }
+
+ return 1;
+}
+
+sub _unzip_az {
+ my $self = shift;
+
+ my $use_list = { 'Archive::Zip' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Archive::Zip'));
+ return METHOD_NA;
+ }
+
+ my $zip = Archive::Zip->new();
+
+ unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) {
+ return $self->_error(loc("Unable to read '%1'", $self->archive));
+ }
+
+ my @files;
+
+
+ ### Address: #43278: Explicitly tell Archive::Zip where to put the files:
+ ### "In my BackPAN indexing, Archive::Zip was extracting things
+ ### in my script's directory instead of the current working directory.
+ ### I traced this back through Archive::Zip::_asLocalName which
+ ### eventually calls File::Spec::Win32::rel2abs which on Windows might
+ ### call Cwd::getdcwd. getdcwd returns the wrong directory in my
+ ### case, even though I think I'm on the same drive.
+ ###
+ ### To fix this, I pass the optional second argument to
+ ### extractMember using the cwd from Archive::Extract." --bdfoy
+
+ ## store cwd() before looping; calls to cwd() can be expensive, and
+ ### it won't change during the loop
+ my $extract_dir = cwd();
+
+ ### have to extract every member individually ###
+ for my $member ($zip->members) {
+ push @files, $member->{fileName};
+
+ ### file to extact to, to avoid the above problem
+ my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
+
+ unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
+ return $self->_error(loc("Extraction of '%1' from '%2' failed",
+ $member->{fileName}, $self->archive ));
+ }
+ }
+
+ my $dir = $self->__get_extract_dir( \@files );
+
+ ### set what files where extract, and where they went ###
+ $self->files( \@files );
+ $self->extract_path( File::Spec->rel2abs($dir) );
+
+ return 1;
+}
+
+sub __get_extract_dir {
+ my $self = shift;
+ my $files = shift || [];
+
+ return unless scalar @$files;
+
+ my($dir1, $dir2);
+ for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
+ my($dir,$pos) = @$aref;
+
+ ### add a catdir(), so that any trailing slashes get
+ ### take care of (removed)
+ ### also, a catdir() normalises './dir/foo' to 'dir/foo';
+ ### which was the problem in bug #23999
+ my $res = -d $files->[$pos]
+ ? File::Spec->catdir( $files->[$pos], '' )
+ : File::Spec->catdir( dirname( $files->[$pos] ) );
+
+ $$dir = $res;
+ }
+
+ ### if the first and last dir don't match, make sure the
+ ### dirname is not set wrongly
+ my $dir;
+
+ ### dirs are the same, so we know for sure what the extract dir is
+ if( $dir1 eq $dir2 ) {
+ $dir = $dir1;
+
+ ### dirs are different.. do they share the base dir?
+ ### if so, use that, if not, fall back to '.'
+ } else {
+ my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
+ my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
+
+ $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
+ }
+
+ return File::Spec->rel2abs( $dir );
+}
+
+#################################
+#
+# Bunzip2 code
+#
+#################################
+
+sub _bunzip2_bin {
+ my $self = shift;
+
+ ### check for /bin/gzip -- we need it ###
+ unless( $self->bin_bunzip2 ) {
+ $self->_error(loc("No '%1' program found", '/bin/bunzip2'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ ### guard against broken bunzip2. See ->have_old_bunzip2()
+ ### for details
+ if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) {
+ return $self->_error(loc("Your bunzip2 version is too old and ".
+ "can only extract files ending in '%1'",
+ '.bz2'));
+ }
+
+ my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to bunzip2 '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+### using cz2, the compact versions... this we use mainly in archive::tar
+### extractor..
+# sub _bunzip2_cz1 {
+# my $self = shift;
+#
+# my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+# unless( can_load( modules => $use_list ) ) {
+# return $self->_error(loc("You do not have '%1' installed - Please " .
+# "install it as soon as possible.",
+# 'IO::Uncompress::Bunzip2'));
+# }
+#
+# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
+# return $self->_error(loc("Unable to open '%1': %2",
+# $self->archive,
+# $IO::Uncompress::Bunzip2::Bunzip2Error));
+#
+# my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+# return $self->_error(loc("Could not open '%1' for writing: %2",
+# $self->_gunzip_to, $! ));
+#
+# my $buffer;
+# $fh->print($buffer) while $bz->read($buffer) > 0;
+# $fh->close;
+#
+# ### set what files where extract, and where they went ###
+# $self->files( [$self->_gunzip_to] );
+# $self->extract_path( File::Spec->rel2abs(cwd()) );
+#
+# return 1;
+# }
+
+sub _bunzip2_bz2 {
+ my $self = shift;
+
+ my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2'));
+ return METHOD_NA;
+ }
+
+ IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
+ or return $self->_error(loc("Unable to uncompress '%1': %2",
+ $self->archive,
+ $IO::Uncompress::Bunzip2::Bunzip2Error));
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+
+#################################
+#
+# unlzma code
+#
+#################################
+
+sub _unlzma_bin {
+ my $self = shift;
+
+ ### check for /bin/unlzma -- we need it ###
+ unless( $self->bin_unlzma ) {
+ $self->_error(loc("No '%1' program found", '/bin/unlzma'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_unlzma, '-c', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unlzma '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+sub _unlzma_cz {
+ my $self = shift;
+
+ my $use_list = { 'Compress::unLZMA' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::unLZMA'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $buffer;
+ $buffer = Compress::unLZMA::uncompressfile( $self->archive );
+ unless ( defined $buffer ) {
+ return $self->_error(loc("Could not unlzma '%1': %2",
+ $self->archive, $@));
+ }
+
+ $self->_print($fh, $buffer) if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+#################################
+#
+# Error code
+#
+#################################
+
+# For printing binaries that avoids interfering globals
+sub _print {
+ my $self = shift;
+ my $fh = shift;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+ return print $fh @_;
+}
+
+sub _error {
+ my $self = shift;
+ my $error = shift;
+ my $lerror = Carp::longmess($error);
+
+ push @{$self->_error_msg}, $error;
+ push @{$self->_error_msg_long}, $lerror;
+
+ ### set $Archive::Extract::WARN to 0 to disable printing
+ ### of errors
+ if( $WARN ) {
+ carp $DEBUG ? $lerror : $error;
+ }
+
+ return;
+}
+
+sub error {
+ my $self = shift;
+
+ ### make sure we have a fallback aref
+ my $aref = do {
+ shift()
+ ? $self->_error_msg_long
+ : $self->_error_msg
+ } || [];
+
+ return join $/, @$aref;
+}
+
+sub _no_buffer_files {
+ my $self = shift;
+ my $file = shift or return;
+ return loc("No buffer captured, unable to tell ".
+ "extracted files or extraction dir for '%1'", $file);
+}
+
+sub _no_buffer_content {
+ my $self = shift;
+ my $file = shift or return;
+ return loc("No buffer captured, unable to get content for '%1'", $file);
+}
+1;
+
+=pod
+
+=head1 HOW IT WORKS
+
+C<Archive::Extract> tries first to determine what type of archive you
+are passing it, by inspecting its suffix. It does not do this by using
+Mime magic, or something related. See C<CAVEATS> below.
+
+Once it has determined the file type, it knows which extraction methods
+it can use on the archive. It will try a perl solution first, then fall
+back to a commandline tool if that fails. If that also fails, it will
+return false, indicating it was unable to extract the archive.
+See the section on C<GLOBAL VARIABLES> to see how to alter this order.
+
+=head1 CAVEATS
+
+=head2 File Extensions
+
+C<Archive::Extract> trusts on the extension of the archive to determine
+what type it is, and what extractor methods therefore can be used. If
+your archives do not have any of the extensions as described in the
+C<new()> method, you will have to specify the type explicitly, or
+C<Archive::Extract> will not be able to extract the archive for you.
+
+=head2 Supporting Very Large Files
+
+C<Archive::Extract> can use either pure perl modules or command line
+programs under the hood. Some of the pure perl modules (like
+C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
+which may not be feasible on your system. Consider setting the global
+variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
+the use of command line programs and won't consume so much memory.
+
+See the C<GLOBAL VARIABLES> section below for details.
+
+=head2 Bunzip2 support of arbitrary extensions.
+
+Older versions of C</bin/bunzip2> do not support arbitrary file
+extensions and insist on a C<.bz2> suffix. Although we do our best
+to guard against this, if you experience a bunzip2 error, it may
+be related to this. For details, please see the C<have_old_bunzip2>
+method.
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Archive::Extract::DEBUG
+
+Set this variable to C<true> to have all calls to command line tools
+be printed out, including all their output.
+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.
+
+Defaults to C<false>.
+
+=head2 $Archive::Extract::WARN
+
+This variable controls whether errors encountered internally by
+C<Archive::Extract> 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 $Archive::Extract::PREFER_BIN
+
+This variables controls whether C<Archive::Extract> should prefer the
+use of perl modules, or commandline tools to extract archives.
+
+Set to C<true> to have C<Archive::Extract> prefer commandline tools.
+
+Defaults to C<false>.
+
+=head1 TODO / CAVEATS
+
+=over 4
+
+=item Mime magic support
+
+Maybe this module should use something like C<File::Type> to determine
+the type, rather than blindly trust the suffix.
+
+=item Thread safety
+
+Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before
+extraction, and a C<chdir> back again after. This is not necessarily
+thread safe. See C<rt.cpan.org> bug C<#45671> for details.
+
+=back
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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:
+
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm
new file mode 100644
index 00000000000..006edbd5c3e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar.pm
@@ -0,0 +1,2146 @@
+### the gnu tar specification:
+### http://www.gnu.org/software/tar/manual/tar.html
+###
+### and the pax format spec, which tar derives from:
+### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html
+
+package Archive::Tar;
+require 5.005_03;
+
+use Cwd;
+use IO::Zlib;
+use IO::File;
+use Carp qw(carp croak);
+use File::Spec ();
+use File::Spec::Unix ();
+use File::Path ();
+
+use Archive::Tar::File;
+use Archive::Tar::Constant;
+
+require Exporter;
+
+use strict;
+use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
+ $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS
+ $INSECURE_EXTRACT_MODE @ISA @EXPORT
+ ];
+
+@ISA = qw[Exporter];
+@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ];
+$DEBUG = 0;
+$WARN = 1;
+$FOLLOW_SYMLINK = 0;
+$VERSION = "1.54";
+$CHOWN = 1;
+$CHMOD = 1;
+$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
+$DO_NOT_USE_PREFIX = 0;
+$INSECURE_EXTRACT_MODE = 0;
+
+BEGIN {
+ use Config;
+ $HAS_PERLIO = $Config::Config{useperlio};
+
+ ### try and load IO::String anyway, so you can dynamically
+ ### switch between perlio and IO::String
+ $HAS_IO_STRING = eval {
+ require IO::String;
+ import IO::String;
+ 1;
+ } || 0;
+}
+
+=head1 NAME
+
+Archive::Tar - module for manipulations of tar archives
+
+=head1 SYNOPSIS
+
+ use Archive::Tar;
+ my $tar = Archive::Tar->new;
+
+ $tar->read('origin.tgz');
+ $tar->extract();
+
+ $tar->add_files('file/foo.pl', 'docs/README');
+ $tar->add_data('file/baz.txt', 'This is the contents now');
+
+ $tar->rename('oldname', 'new/file/name');
+
+ $tar->write('files.tar'); # plain tar
+ $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
+ $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed
+
+=head1 DESCRIPTION
+
+Archive::Tar provides an object oriented mechanism for handling tar
+files. It provides class methods for quick and easy files handling
+while also allowing for the creation of tar file objects for custom
+manipulation. If you have the IO::Zlib module installed,
+Archive::Tar will also support compressed or gzipped tar files.
+
+An object of class Archive::Tar represents a .tar(.gz) archive full
+of files and things.
+
+=head1 Object Methods
+
+=head2 Archive::Tar->new( [$file, $compressed] )
+
+Returns a new Tar object. If given any arguments, C<new()> calls the
+C<read()> method automatically, passing on the arguments provided to
+the C<read()> method.
+
+If C<new()> is invoked with arguments and the C<read()> method fails
+for any reason, C<new()> returns undef.
+
+=cut
+
+my $tmpl = {
+ _data => [ ],
+ _file => 'Unknown',
+};
+
+### install get/set accessors for this object.
+for my $key ( keys %$tmpl ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+ return $self->{$key};
+ }
+}
+
+sub new {
+ my $class = shift;
+ $class = ref $class if ref $class;
+
+ ### copying $tmpl here since a shallow copy makes it use the
+ ### same aref, causing for files to remain in memory always.
+ my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class;
+
+ if (@_) {
+ unless ( $obj->read( @_ ) ) {
+ $obj->_error(qq[No data could be read from file]);
+ return;
+ }
+ }
+
+ return $obj;
+}
+
+=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] )
+
+Read the given tar file into memory.
+The first argument can either be the name of a file or a reference to
+an already open filehandle (or an IO::Zlib object if it's compressed)
+
+The C<read> will I<replace> any previous content in C<$tar>!
+
+The second argument may be considered optional, but remains for
+backwards compatibility. Archive::Tar now looks at the file
+magic to determine what class should be used to open the file
+and will transparently Do The Right Thing.
+
+Archive::Tar will warn if you try to pass a bzip2 compressed file and the
+IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return.
+
+Note that you can currently B<not> pass a C<gzip> compressed
+filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed
+filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string
+containing the full archive information (either compressed or
+uncompressed). These are worth while features, but not currently
+implemented. See the C<TODO> section.
+
+The third argument can be a hash reference with options. Note that
+all options are case-sensitive.
+
+=over 4
+
+=item limit
+
+Do not read more than C<limit> files. This is useful if you have
+very big archives, and are only interested in the first few files.
+
+=item filter
+
+Can be set to a regular expression. Only files with names that match
+the expression will be read.
+
+=item extract
+
+If set to true, immediately extract entries when reading them. This
+gives you the same memory break as the C<extract_archive> function.
+Note however that entries will not be read into memory, but written
+straight to disk. This means no C<Archive::Tar::File> objects are
+created for you to inspect.
+
+=back
+
+All files are stored internally as C<Archive::Tar::File> objects.
+Please consult the L<Archive::Tar::File> documentation for details.
+
+Returns the number of files read in scalar context, and a list of
+C<Archive::Tar::File> objects in list context.
+
+=cut
+
+sub read {
+ my $self = shift;
+ my $file = shift;
+ my $gzip = shift || 0;
+ my $opts = shift || {};
+
+ unless( defined $file ) {
+ $self->_error( qq[No file to read from!] );
+ return;
+ } else {
+ $self->_file( $file );
+ }
+
+ my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) )
+ or return;
+
+ my $data = $self->_read_tar( $handle, $opts ) or return;
+
+ $self->_data( $data );
+
+ return wantarray ? @$data : scalar @$data;
+}
+
+sub _get_handle {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ return $file if ref $file;
+ my $compress = shift || 0;
+ my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
+
+
+ ### get a FH opened to the right class, so we can use it transparently
+ ### throughout the program
+ my $fh;
+ { ### reading magic only makes sense if we're opening a file for
+ ### reading. otherwise, just use what the user requested.
+ my $magic = '';
+ if( MODE_READ->($mode) ) {
+ open my $tmp, $file or do {
+ $self->_error( qq[Could not open '$file' for reading: $!] );
+ return;
+ };
+
+ ### read the first 4 bites of the file to figure out which class to
+ ### use to open the file.
+ sysread( $tmp, $magic, 4 );
+ close $tmp;
+ }
+
+ ### is it bzip?
+ ### if you asked specifically for bzip compression, or if we're in
+ ### read mode and the magic numbers add up, use bzip
+ if( BZIP and (
+ ($compress eq COMPRESS_BZIP) or
+ ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM )
+ )
+ ) {
+
+ ### different reader/writer modules, different error vars... sigh
+ if( MODE_READ->($mode) ) {
+ $fh = IO::Uncompress::Bunzip2->new( $file ) or do {
+ $self->_error( qq[Could not read '$file': ] .
+ $IO::Uncompress::Bunzip2::Bunzip2Error
+ );
+ return;
+ };
+
+ } else {
+ $fh = IO::Compress::Bzip2->new( $file ) or do {
+ $self->_error( qq[Could not write to '$file': ] .
+ $IO::Compress::Bzip2::Bzip2Error
+ );
+ return;
+ };
+ }
+
+ ### is it gzip?
+ ### if you asked for compression, if you wanted to read or the gzip
+ ### magic number is present (redundant with read)
+ } elsif( ZLIB and (
+ $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM
+ )
+ ) {
+ $fh = IO::Zlib->new;
+
+ unless( $fh->open( $file, $mode ) ) {
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
+ return;
+ }
+
+ ### is it plain tar?
+ } else {
+ $fh = IO::File->new;
+
+ unless( $fh->open( $file, $mode ) ) {
+ $self->_error(qq[Could not create filehandle for '$file': $!]);
+ return;
+ }
+
+ ### enable bin mode on tar archives
+ binmode $fh;
+ }
+ }
+
+ return $fh;
+}
+
+
+sub _read_tar {
+ my $self = shift;
+ my $handle = shift or return;
+ my $opts = shift || {};
+
+ my $count = $opts->{limit} || 0;
+ my $filter = $opts->{filter};
+ my $extract = $opts->{extract} || 0;
+
+ ### set a cap on the amount of files to extract ###
+ my $limit = 0;
+ $limit = 1 if $count > 0;
+
+ my $tarfile = [ ];
+ my $chunk;
+ my $read = 0;
+ my $real_name; # to set the name of a file when
+ # we're encountering @longlink
+ my $data;
+
+ LOOP:
+ while( $handle->read( $chunk, HEAD ) ) {
+ ### IO::Zlib doesn't support this yet
+ my $offset = eval { tell $handle } || 'unknown';
+
+ unless( $read++ ) {
+ my $gzip = GZIP_MAGIC_NUM;
+ if( $chunk =~ /$gzip/ ) {
+ $self->_error( qq[Cannot read compressed format in tar-mode] );
+ return;
+ }
+
+ ### size is < HEAD, which means a corrupted file, as the minimum
+ ### length is _at least_ HEAD
+ if (length $chunk != HEAD) {
+ $self->_error( qq[Cannot read enough bytes from the tarfile] );
+ return;
+ }
+ }
+
+ ### if we can't read in all bytes... ###
+ last if length $chunk != HEAD;
+
+ ### Apparently this should really be two blocks of 512 zeroes,
+ ### but GNU tar sometimes gets it wrong. See comment in the
+ ### source code (tar.c) to GNU cpio.
+ next if $chunk eq TAR_END;
+
+ ### according to the posix spec, the last 12 bytes of the header are
+ ### null bytes, to pad it to a 512 byte block. That means if these
+ ### bytes are NOT null bytes, it's a corrrupt header. See:
+ ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
+ ### line 111
+ { my $nulls = join '', "\0" x 12;
+ unless( $nulls eq substr( $chunk, 500, 12 ) ) {
+ $self->_error( qq[Invalid header block at offset $offset] );
+ next LOOP;
+ }
+ }
+
+ ### pass the realname, so we can set it 'proper' right away
+ ### some of the heuristics are done on the name, so important
+ ### to set it ASAP
+ my $entry;
+ { my %extra_args = ();
+ $extra_args{'name'} = $$real_name if defined $real_name;
+
+ unless( $entry = Archive::Tar::File->new( chunk => $chunk,
+ %extra_args )
+ ) {
+ $self->_error( qq[Couldn't read chunk at offset $offset] );
+ next LOOP;
+ }
+ }
+
+ ### ignore labels:
+ ### http://www.gnu.org/manual/tar/html_node/tar_139.html
+ next if $entry->is_label;
+
+ if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) {
+
+ if ( $entry->is_file && !$entry->validate ) {
+ ### sometimes the chunk is rather fux0r3d and a whole 512
+ ### bytes ends up in the ->name area.
+ ### clean it up, if need be
+ my $name = $entry->name;
+ $name = substr($name, 0, 100) if length $name > 100;
+ $name =~ s/\n/ /g;
+
+ $self->_error( $name . qq[: checksum error] );
+ next LOOP;
+ }
+
+ my $block = BLOCK_SIZE->( $entry->size );
+
+ $data = $entry->get_content_by_ref;
+
+ ### just read everything into memory
+ ### can't do lazy loading since IO::Zlib doesn't support 'seek'
+ ### this is because Compress::Zlib doesn't support it =/
+ ### this reads in the whole data in one read() call.
+ if( $handle->read( $$data, $block ) < $block ) {
+ $self->_error( qq[Read error on tarfile (missing data) '].
+ $entry->full_path ."' at offset $offset" );
+ next LOOP;
+ }
+
+ ### throw away trailing garbage ###
+ substr ($$data, $entry->size) = "" if defined $$data;
+
+ ### part II of the @LongLink munging -- need to do /after/
+ ### the checksum check.
+ if( $entry->is_longlink ) {
+ ### weird thing in tarfiles -- if the file is actually a
+ ### @LongLink, the data part seems to have a trailing ^@
+ ### (unprintable) char. to display, pipe output through less.
+ ### but that doesn't *always* happen.. so check if the last
+ ### character is a control character, and if so remove it
+ ### at any rate, we better remove that character here, or tests
+ ### like 'eq' and hashlook ups based on names will SO not work
+ ### remove it by calculating the proper size, and then
+ ### tossing out everything that's longer than that size.
+
+ ### count number of nulls
+ my $nulls = $$data =~ tr/\0/\0/;
+
+ ### cut data + size by that many bytes
+ $entry->size( $entry->size - $nulls );
+ substr ($$data, $entry->size) = "";
+ }
+ }
+
+ ### clean up of the entries.. posix tar /apparently/ has some
+ ### weird 'feature' that allows for filenames > 255 characters
+ ### they'll put a header in with as name '././@LongLink' and the
+ ### contents will be the name of the /next/ file in the archive
+ ### pretty crappy and kludgy if you ask me
+
+ ### set the name for the next entry if this is a @LongLink;
+ ### this is one ugly hack =/ but needed for direct extraction
+ if( $entry->is_longlink ) {
+ $real_name = $data;
+ next LOOP;
+ } elsif ( defined $real_name ) {
+ $entry->name( $$real_name );
+ $entry->prefix('');
+ undef $real_name;
+ }
+
+ ### skip this entry if we're filtering
+ if ($filter && $entry->name !~ $filter) {
+ next LOOP;
+
+ ### skip this entry if it's a pax header. This is a special file added
+ ### by, among others, git-generated tarballs. It holds comments and is
+ ### not meant for extracting. See #38932: pax_global_header extracted
+ } elsif ( $entry->name eq PAX_HEADER ) {
+ next LOOP;
+ }
+
+ $self->_extract_file( $entry ) if $extract
+ && !$entry->is_longlink
+ && !$entry->is_unknown
+ && !$entry->is_label;
+
+ ### Guard against tarfiles with garbage at the end
+ last LOOP if $entry->name eq '';
+
+ ### push only the name on the rv if we're extracting
+ ### -- for extract_archive
+ push @$tarfile, ($extract ? $entry->name : $entry);
+
+ if( $limit ) {
+ $count-- unless $entry->is_longlink || $entry->is_dir;
+ last LOOP unless $count;
+ }
+ } continue {
+ undef $data;
+ }
+
+ return $tarfile;
+}
+
+=head2 $tar->contains_file( $filename )
+
+Check if the archive contains a certain file.
+It will return true if the file is in the archive, false otherwise.
+
+Note however, that this function does an exact match using C<eq>
+on the full path. So it cannot compensate for case-insensitive file-
+systems or compare 2 paths to see if they would point to the same
+underlying file.
+
+=cut
+
+sub contains_file {
+ my $self = shift;
+ my $full = shift;
+
+ return unless defined $full;
+
+ ### don't warn if the entry isn't there.. that's what this function
+ ### is for after all.
+ local $WARN = 0;
+ return 1 if $self->_find_entry($full);
+ return;
+}
+
+=head2 $tar->extract( [@filenames] )
+
+Write files whose names are equivalent to any of the names in
+C<@filenames> to disk, creating subdirectories as necessary. This
+might not work too well under VMS.
+Under MacPerl, the file's modification time will be converted to the
+MacOS zero of time, and appropriate conversions will be done to the
+path. However, the length of each element of the path is not
+inspected to see whether it's longer than MacOS currently allows (32
+characters).
+
+If C<extract> is called without a list of file names, the entire
+contents of the archive are extracted.
+
+Returns a list of filenames extracted.
+
+=cut
+
+sub extract {
+ my $self = shift;
+ my @args = @_;
+ my @files;
+
+ # use the speed optimization for all extracted files
+ local($self->{cwd}) = cwd() unless $self->{cwd};
+
+ ### you requested the extraction of only certian files
+ if( @args ) {
+ for my $file ( @args ) {
+
+ ### it's already an object?
+ if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
+ push @files, $file;
+ next;
+
+ ### go find it then
+ } else {
+
+ my $found;
+ for my $entry ( @{$self->_data} ) {
+ next unless $file eq $entry->full_path;
+
+ ### we found the file you're looking for
+ push @files, $entry;
+ $found++;
+ }
+
+ unless( $found ) {
+ return $self->_error(
+ qq[Could not find '$file' in archive] );
+ }
+ }
+ }
+
+ ### just grab all the file items
+ } else {
+ @files = $self->get_files;
+ }
+
+ ### nothing found? that's an error
+ unless( scalar @files ) {
+ $self->_error( qq[No files found for ] . $self->_file );
+ return;
+ }
+
+ ### now extract them
+ for my $entry ( @files ) {
+ unless( $self->_extract_file( $entry ) ) {
+ $self->_error(q[Could not extract ']. $entry->full_path .q['] );
+ return;
+ }
+ }
+
+ return @files;
+}
+
+=head2 $tar->extract_file( $file, [$extract_path] )
+
+Write an entry, whose name is equivalent to the file name provided to
+disk. Optionally takes a second parameter, which is the full native
+path (including filename) the entry will be written to.
+
+For example:
+
+ $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
+
+ $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' );
+
+Returns true on success, false on failure.
+
+=cut
+
+sub extract_file {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $alt = shift;
+
+ my $entry = $self->_find_entry( $file )
+ or $self->_error( qq[Could not find an entry for '$file'] ), return;
+
+ return $self->_extract_file( $entry, $alt );
+}
+
+sub _extract_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $alt = shift;
+
+ ### you wanted an alternate extraction location ###
+ my $name = defined $alt ? $alt : $entry->full_path;
+
+ ### splitpath takes a bool at the end to indicate
+ ### that it's splitting a dir
+ my ($vol,$dirs,$file);
+ if ( defined $alt ) { # It's a local-OS path
+ ($vol,$dirs,$file) = File::Spec->splitpath( $alt,
+ $entry->is_dir );
+ } else {
+ ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
+ $entry->is_dir );
+ }
+
+ my $dir;
+ ### is $name an absolute path? ###
+ if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) {
+
+ ### absolute names are not allowed to be in tarballs under
+ ### strict mode, so only allow it if a user tells us to do it
+ if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is an absolute path. ].
+ q[Not extracting absolute paths under SECURE EXTRACT MODE]
+ );
+ return;
+ }
+
+ ### user asked us to, it's fine.
+ $dir = File::Spec->catpath( $vol, $dirs, "" );
+
+ ### it's a relative path ###
+ } else {
+ my $cwd = (ref $self and defined $self->{cwd})
+ ? $self->{cwd}
+ : cwd();
+
+ my @dirs = defined $alt
+ ? File::Spec->splitdir( $dirs ) # It's a local-OS path
+ : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely
+ # straight from the tarball
+
+ if( not defined $alt and
+ not $INSECURE_EXTRACT_MODE
+ ) {
+
+ ### paths that leave the current directory are not allowed under
+ ### strict mode, so only allow it if a user tells us to do this.
+ if( grep { $_ eq '..' } @dirs ) {
+
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is attempting to leave ].
+ q[the current working directory. Not extracting under ].
+ q[SECURE EXTRACT MODE]
+ );
+ return;
+ }
+
+ ### the archive may be asking us to extract into a symlink. This
+ ### is not sane and a possible security issue, as outlined here:
+ ### https://rt.cpan.org/Ticket/Display.html?id=30380
+ ### https://bugzilla.redhat.com/show_bug.cgi?id=295021
+ ### https://issues.rpath.com/browse/RPL-1716
+ my $full_path = $cwd;
+ for my $d ( @dirs ) {
+ $full_path = File::Spec->catdir( $full_path, $d );
+
+ ### we've already checked this one, and it's safe. Move on.
+ next if ref $self and $self->{_link_cache}->{$full_path};
+
+ if( -l $full_path ) {
+ my $to = readlink $full_path;
+ my $diag = "symlinked directory ($full_path => $to)";
+
+ $self->_error(
+ q[Entry ']. $entry->full_path .q[' is attempting to ].
+ qq[extract to a $diag. This is considered a security ].
+ q[vulnerability and not allowed under SECURE EXTRACT ].
+ q[MODE]
+ );
+ return;
+ }
+
+ ### XXX keep a cache if possible, so the stats become cheaper:
+ $self->{_link_cache}->{$full_path} = 1 if ref $self;
+ }
+ }
+
+ ### '.' is the directory delimiter on VMS, which has to be escaped
+ ### or changed to '_' on vms. vmsify is used, because older versions
+ ### of vmspath do not handle this properly.
+ ### Must not add a '/' to an empty directory though.
+ map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
+
+ my ($cwd_vol,$cwd_dir,$cwd_file)
+ = File::Spec->splitpath( $cwd );
+ my @cwd = File::Spec->splitdir( $cwd_dir );
+ push @cwd, $cwd_file if length $cwd_file;
+
+ ### We need to pass '' as the last elemant to catpath. Craig Berry
+ ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
+ ### The root problem is that splitpath on UNIX always returns the
+ ### final path element as a file even if it is a directory, and of
+ ### course there is no way it can know the difference without checking
+ ### against the filesystem, which it is documented as not doing. When
+ ### you turn around and call catpath, on VMS you have to know which bits
+ ### are directory bits and which bits are file bits. In this case we
+ ### know the result should be a directory. I had thought you could omit
+ ### the file argument to catpath in such a case, but apparently on UNIX
+ ### you can't.
+ $dir = File::Spec->catpath(
+ $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
+ );
+
+ ### catdir() returns undef if the path is longer than 255 chars on
+ ### older VMS systems.
+ unless ( defined $dir ) {
+ $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
+ return;
+ }
+
+ }
+
+ if( -e $dir && !-d _ ) {
+ $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
+ return;
+ }
+
+ unless ( -d _ ) {
+ eval { File::Path::mkpath( $dir, 0, 0777 ) };
+ if( $@ ) {
+ my $fp = $entry->full_path;
+ $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
+ return;
+ }
+
+ ### XXX chown here? that might not be the same as in the archive
+ ### as we're only chown'ing to the owner of the file we're extracting
+ ### not to the owner of the directory itself, which may or may not
+ ### be another entry in the archive
+ ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
+ ### way to go.
+ #if( $CHOWN && CAN_CHOWN ) {
+ # chown $entry->uid, $entry->gid, $dir or
+ # $self->_error( qq[Could not set uid/gid on '$dir'] );
+ #}
+ }
+
+ ### we're done if we just needed to create a dir ###
+ return 1 if $entry->is_dir;
+
+ my $full = File::Spec->catfile( $dir, $file );
+
+ if( $entry->is_unknown ) {
+ $self->_error( qq[Unknown file type for file '$full'] );
+ return;
+ }
+
+ if( length $entry->type && $entry->is_file ) {
+ my $fh = IO::File->new;
+ $fh->open( '>' . $full ) or (
+ $self->_error( qq[Could not open file '$full': $!] ),
+ return
+ );
+
+ if( $entry->size ) {
+ binmode $fh;
+ syswrite $fh, $entry->data or (
+ $self->_error( qq[Could not write data to '$full'] ),
+ return
+ );
+ }
+
+ close $fh or (
+ $self->_error( qq[Could not close file '$full'] ),
+ return
+ );
+
+ } else {
+ $self->_make_special_file( $entry, $full ) or return;
+ }
+
+ ### only update the timestamp if it's not a symlink; that will change the
+ ### timestamp of the original. This addresses bug #33669: Could not update
+ ### timestamp warning on symlinks
+ if( not -l $full ) {
+ utime time, $entry->mtime - TIME_OFFSET, $full or
+ $self->_error( qq[Could not update timestamp] );
+ }
+
+ if( $CHOWN && CAN_CHOWN->() ) {
+ chown $entry->uid, $entry->gid, $full or
+ $self->_error( qq[Could not set uid/gid on '$full'] );
+ }
+
+ ### only chmod if we're allowed to, but never chmod symlinks, since they'll
+ ### change the perms on the file they're linking too...
+ if( $CHMOD and not -l $full ) {
+ my $mode = $entry->mode;
+ unless ($SAME_PERMISSIONS) {
+ $mode &= ~(oct(7000) | umask);
+ }
+ chmod $mode, $full or
+ $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
+ }
+
+ return 1;
+}
+
+sub _make_special_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $file = shift; return unless defined $file;
+
+ my $err;
+
+ if( $entry->is_symlink ) {
+ my $fail;
+ if( ON_UNIX ) {
+ symlink( $entry->linkname, $file ) or $fail++;
+
+ } else {
+ $self->_extract_special_file_as_plain_file( $entry, $file )
+ or $fail++;
+ }
+
+ $err = qq[Making symbolic link '$file' to '] .
+ $entry->linkname .q[' failed] if $fail;
+
+ } elsif ( $entry->is_hardlink ) {
+ my $fail;
+ if( ON_UNIX ) {
+ link( $entry->linkname, $file ) or $fail++;
+
+ } else {
+ $self->_extract_special_file_as_plain_file( $entry, $file )
+ or $fail++;
+ }
+
+ $err = qq[Making hard link from '] . $entry->linkname .
+ qq[' to '$file' failed] if $fail;
+
+ } elsif ( $entry->is_fifo ) {
+ ON_UNIX && !system('mknod', $file, 'p') or
+ $err = qq[Making fifo ']. $entry->name .qq[' failed];
+
+ } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
+ my $mode = $entry->is_blockdev ? 'b' : 'c';
+
+ ON_UNIX && !system('mknod', $file, $mode,
+ $entry->devmajor, $entry->devminor) or
+ $err = qq[Making block device ']. $entry->name .qq[' (maj=] .
+ $entry->devmajor . qq[ min=] . $entry->devminor .
+ qq[) failed.];
+
+ } elsif ( $entry->is_socket ) {
+ ### the original doesn't do anything special for sockets.... ###
+ 1;
+ }
+
+ return $err ? $self->_error( $err ) : 1;
+}
+
+### don't know how to make symlinks, let's just extract the file as
+### a plain file
+sub _extract_special_file_as_plain_file {
+ my $self = shift;
+ my $entry = shift or return;
+ my $file = shift; return unless defined $file;
+
+ my $err;
+ TRY: {
+ my $orig = $self->_find_entry( $entry->linkname );
+
+ unless( $orig ) {
+ $err = qq[Could not find file '] . $entry->linkname .
+ qq[' in memory.];
+ last TRY;
+ }
+
+ ### clone the entry, make it appear as a normal file ###
+ my $clone = $entry->clone;
+ $clone->_downgrade_to_plainfile;
+ $self->_extract_file( $clone, $file ) or last TRY;
+
+ return 1;
+ }
+
+ return $self->_error($err);
+}
+
+=head2 $tar->list_files( [\@properties] )
+
+Returns a list of the names of all the files in the archive.
+
+If C<list_files()> is passed an array reference as its first argument
+it returns a list of hash references containing the requested
+properties of each file. The following list of properties is
+supported: name, size, mtime (last modified date), mode, uid, gid,
+linkname, uname, gname, devmajor, devminor, prefix.
+
+Passing an array reference containing only one element, 'name', is
+special cased to return a list of names rather than a list of hash
+references, making it equivalent to calling C<list_files> without
+arguments.
+
+=cut
+
+sub list_files {
+ my $self = shift;
+ my $aref = shift || [ ];
+
+ unless( $self->_data ) {
+ $self->read() or return;
+ }
+
+ if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
+ return map { $_->full_path } @{$self->_data};
+ } else {
+
+ #my @rv;
+ #for my $obj ( @{$self->_data} ) {
+ # push @rv, { map { $_ => $obj->$_() } @$aref };
+ #}
+ #return @rv;
+
+ ### this does the same as the above.. just needs a +{ }
+ ### to make sure perl doesn't confuse it for a block
+ return map { my $o=$_;
+ +{ map { $_ => $o->$_() } @$aref }
+ } @{$self->_data};
+ }
+}
+
+sub _find_entry {
+ my $self = shift;
+ my $file = shift;
+
+ unless( defined $file ) {
+ $self->_error( qq[No file specified] );
+ return;
+ }
+
+ ### it's an object already
+ return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
+
+ for my $entry ( @{$self->_data} ) {
+ my $path = $entry->full_path;
+ return $entry if $path eq $file;
+ }
+
+ $self->_error( qq[No such file in archive: '$file'] );
+ return;
+}
+
+=head2 $tar->get_files( [@filenames] )
+
+Returns the C<Archive::Tar::File> objects matching the filenames
+provided. If no filename list was passed, all C<Archive::Tar::File>
+objects in the current Tar object are returned.
+
+Please refer to the C<Archive::Tar::File> documentation on how to
+handle these objects.
+
+=cut
+
+sub get_files {
+ my $self = shift;
+
+ return @{ $self->_data } unless @_;
+
+ my @list;
+ for my $file ( @_ ) {
+ push @list, grep { defined } $self->_find_entry( $file );
+ }
+
+ return @list;
+}
+
+=head2 $tar->get_content( $file )
+
+Return the content of the named file.
+
+=cut
+
+sub get_content {
+ my $self = shift;
+ my $entry = $self->_find_entry( shift ) or return;
+
+ return $entry->data;
+}
+
+=head2 $tar->replace_content( $file, $content )
+
+Make the string $content be the content for the file named $file.
+
+=cut
+
+sub replace_content {
+ my $self = shift;
+ my $entry = $self->_find_entry( shift ) or return;
+
+ return $entry->replace_content( shift );
+}
+
+=head2 $tar->rename( $file, $new_name )
+
+Rename the file of the in-memory archive to $new_name.
+
+Note that you must specify a Unix path for $new_name, since per tar
+standard, all files in the archive must be Unix paths.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub rename {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $new = shift; return unless defined $new;
+
+ my $entry = $self->_find_entry( $file ) or return;
+
+ return $entry->rename( $new );
+}
+
+=head2 $tar->remove (@filenamelist)
+
+Removes any entries with names matching any of the given filenames
+from the in-memory archive. Returns a list of C<Archive::Tar::File>
+objects that remain.
+
+=cut
+
+sub remove {
+ my $self = shift;
+ my @list = @_;
+
+ my %seen = map { $_->full_path => $_ } @{$self->_data};
+ delete $seen{ $_ } for @list;
+
+ $self->_data( [values %seen] );
+
+ return values %seen;
+}
+
+=head2 $tar->clear
+
+C<clear> clears the current in-memory archive. This effectively gives
+you a 'blank' object, ready to be filled again. Note that C<clear>
+only has effect on the object, not the underlying tarfile.
+
+=cut
+
+sub clear {
+ my $self = shift or return;
+
+ $self->_data( [] );
+ $self->_file( '' );
+
+ return 1;
+}
+
+
+=head2 $tar->write ( [$file, $compressed, $prefix] )
+
+Write the in-memory archive to disk. The first argument can either
+be the name of a file or a reference to an already open filehandle (a
+GLOB reference).
+
+The second argument is used to indicate compression. You can either
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
+to be the C<gzip> compression level (between 1 and 9), but the use of
+constants is prefered:
+
+ # write a gzip compressed file
+ $tar->write( 'out.tgz', COMPRESS_GZIP );
+
+ # write a bzip compressed file
+ $tar->write( 'out.tbz', COMPRESS_BZIP );
+
+Note that when you pass in a filehandle, the compression argument
+is ignored, as all files are printed verbatim to your filehandle.
+If you wish to enable compression with filehandles, use an
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
+
+The third argument is an optional prefix. All files will be tucked
+away in the directory you specify as prefix. So if you have files
+'a' and 'b' in your archive, and you specify 'foo' as prefix, they
+will be written to the archive as 'foo/a' and 'foo/b'.
+
+If no arguments are given, C<write> returns the entire formatted
+archive as a string, which could be useful if you'd like to stuff the
+archive into a socket or a pipe to gzip or something.
+
+
+=cut
+
+sub write {
+ my $self = shift;
+ my $file = shift; $file = '' unless defined $file;
+ my $gzip = shift || 0;
+ my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
+ my $dummy = '';
+
+ ### only need a handle if we have a file to print to ###
+ my $handle = length($file)
+ ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
+ or return )
+ : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h }
+ : $HAS_IO_STRING ? IO::String->new
+ : __PACKAGE__->no_string_support();
+
+ ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a
+ ### corrupt TAR file. Must clear out $\ to make sure no garbage is
+ ### printed to the archive
+ local $\;
+
+ for my $entry ( @{$self->_data} ) {
+ ### entries to be written to the tarfile ###
+ my @write_me;
+
+ ### only now will we change the object to reflect the current state
+ ### of the name and prefix fields -- this needs to be limited to
+ ### write() only!
+ my $clone = $entry->clone;
+
+
+ ### so, if you don't want use to use the prefix, we'll stuff
+ ### everything in the name field instead
+ if( $DO_NOT_USE_PREFIX ) {
+
+ ### you might have an extended prefix, if so, set it in the clone
+ ### XXX is ::Unix right?
+ $clone->name( length $ext_prefix
+ ? File::Spec::Unix->catdir( $ext_prefix,
+ $clone->full_path)
+ : $clone->full_path );
+ $clone->prefix( '' );
+
+ ### otherwise, we'll have to set it properly -- prefix part in the
+ ### prefix and name part in the name field.
+ } else {
+
+ ### split them here, not before!
+ my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
+
+ ### you might have an extended prefix, if so, set it in the clone
+ ### XXX is ::Unix right?
+ $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
+ if length $ext_prefix;
+
+ $clone->prefix( $prefix );
+ $clone->name( $name );
+ }
+
+ ### names are too long, and will get truncated if we don't add a
+ ### '@LongLink' file...
+ my $make_longlink = ( length($clone->name) > NAME_LENGTH or
+ length($clone->prefix) > PREFIX_LENGTH
+ ) || 0;
+
+ ### perhaps we need to make a longlink file?
+ if( $make_longlink ) {
+ my $longlink = Archive::Tar::File->new(
+ data => LONGLINK_NAME,
+ $clone->full_path,
+ { type => LONGLINK }
+ );
+
+ unless( $longlink ) {
+ $self->_error( qq[Could not create 'LongLink' entry for ] .
+ qq[oversize file '] . $clone->full_path ."'" );
+ return;
+ };
+
+ push @write_me, $longlink;
+ }
+
+ push @write_me, $clone;
+
+ ### write the one, optionally 2 a::t::file objects to the handle
+ for my $clone (@write_me) {
+
+ ### if the file is a symlink, there are 2 options:
+ ### either we leave the symlink intact, but then we don't write any
+ ### data OR we follow the symlink, which means we actually make a
+ ### copy. if we do the latter, we have to change the TYPE of the
+ ### clone to 'FILE'
+ my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
+ my $data_ok = !$clone->is_symlink && $clone->has_content;
+
+ ### downgrade to a 'normal' file if it's a symlink we're going to
+ ### treat as a regular file
+ $clone->_downgrade_to_plainfile if $link_ok;
+
+ ### get the header for this block
+ my $header = $self->_format_tar_entry( $clone );
+ unless( $header ) {
+ $self->_error(q[Could not format header for: ] .
+ $clone->full_path );
+ return;
+ }
+
+ unless( print $handle $header ) {
+ $self->_error(q[Could not write header for: ] .
+ $clone->full_path);
+ return;
+ }
+
+ if( $link_ok or $data_ok ) {
+ unless( print $handle $clone->data ) {
+ $self->_error(q[Could not write data for: ] .
+ $clone->full_path);
+ return;
+ }
+
+ ### pad the end of the clone if required ###
+ print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
+ }
+
+ } ### done writing these entries
+ }
+
+ ### write the end markers ###
+ print $handle TAR_END x 2 or
+ return $self->_error( qq[Could not write tar end markers] );
+
+ ### did you want it written to a file, or returned as a string? ###
+ my $rv = length($file) ? 1
+ : $HAS_PERLIO ? $dummy
+ : do { seek $handle, 0, 0; local $/; <$handle> };
+
+ ### make sure to close the handle;
+ close $handle;
+
+ return $rv;
+}
+
+sub _format_tar_entry {
+ my $self = shift;
+ my $entry = shift or return;
+ my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
+ my $no_prefix = shift || 0;
+
+ my $file = $entry->name;
+ my $prefix = $entry->prefix; $prefix = '' unless defined $prefix;
+
+ ### remove the prefix from the file name
+ ### not sure if this is still neeeded --kane
+ ### no it's not -- Archive::Tar::File->_new_from_file will take care of
+ ### this for us. Even worse, this would break if we tried to add a file
+ ### like x/x.
+ #if( length $prefix ) {
+ # $file =~ s/^$match//;
+ #}
+
+ $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
+ if length $ext_prefix;
+
+ ### not sure why this is... ###
+ my $l = PREFIX_LENGTH; # is ambiguous otherwise...
+ substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
+
+ my $f1 = "%06o"; my $f2 = "%11o";
+
+ ### this might be optimizable with a 'changed' flag in the file objects ###
+ my $tar = pack (
+ PACK,
+ $file,
+
+ (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
+ (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
+
+ "", # checksum field - space padded a bit down
+
+ (map { $entry->$_() } qw[type linkname magic]),
+
+ $entry->version || TAR_VERSION,
+
+ (map { $entry->$_() } qw[uname gname]),
+ (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
+
+ ($no_prefix ? '' : $prefix)
+ );
+
+ ### add the checksum ###
+ substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
+
+ return $tar;
+}
+
+=head2 $tar->add_files( @filenamelist )
+
+Takes a list of filenames and adds them to the in-memory archive.
+
+The path to the file is automatically converted to a Unix like
+equivalent for use in the archive, and, if on MacOS, the file's
+modification time is converted from the MacOS epoch to the Unix epoch.
+So tar archives created on MacOS with B<Archive::Tar> can be read
+both with I<tar> on Unix and applications like I<suntar> or
+I<Stuffit Expander> on MacOS.
+
+Be aware that the file's type/creator and resource fork will be lost,
+which is usually what you want in cross-platform archives.
+
+Instead of a filename, you can also pass it an existing C<Archive::Tar::File>
+object from, for example, another archive. The object will be clone, and
+effectively be a copy of the original, not an alias.
+
+Returns a list of C<Archive::Tar::File> objects that were just added.
+
+=cut
+
+sub add_files {
+ my $self = shift;
+ my @files = @_ or return;
+
+ my @rv;
+ for my $file ( @files ) {
+
+ ### you passed an Archive::Tar::File object
+ ### clone it so we don't accidentally have a reference to
+ ### an object from another archive
+ if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) {
+ push @rv, $file->clone;
+ next;
+ }
+
+ unless( -e $file || -l $file ) {
+ $self->_error( qq[No such file: '$file'] );
+ next;
+ }
+
+ my $obj = Archive::Tar::File->new( file => $file );
+ unless( $obj ) {
+ $self->_error( qq[Unable to add file: '$file'] );
+ next;
+ }
+
+ push @rv, $obj;
+ }
+
+ push @{$self->{_data}}, @rv;
+
+ return @rv;
+}
+
+=head2 $tar->add_data ( $filename, $data, [$opthashref] )
+
+Takes a filename, a scalar full of data and optionally a reference to
+a hash with specific options.
+
+Will add a file to the in-memory archive, with name C<$filename> and
+content C<$data>. Specific properties can be set using C<$opthashref>.
+The following list of properties is supported: name, size, mtime
+(last modified date), mode, uid, gid, linkname, uname, gname,
+devmajor, devminor, prefix, type. (On MacOS, the file's path and
+modification times are converted to Unix equivalents.)
+
+Valid values for the file type are the following constants defined in
+Archive::Tar::Constants:
+
+=over 4
+
+=item FILE
+
+Regular file.
+
+=item HARDLINK
+
+=item SYMLINK
+
+Hard and symbolic ("soft") links; linkname should specify target.
+
+=item CHARDEV
+
+=item BLOCKDEV
+
+Character and block devices. devmajor and devminor should specify the major
+and minor device numbers.
+
+=item DIR
+
+Directory.
+
+=item FIFO
+
+FIFO (named pipe).
+
+=item SOCKET
+
+Socket.
+
+=back
+
+Returns the C<Archive::Tar::File> object that was just added, or
+C<undef> on failure.
+
+=cut
+
+sub add_data {
+ my $self = shift;
+ my ($file, $data, $opt) = @_;
+
+ my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
+ unless( $obj ) {
+ $self->_error( qq[Unable to add file: '$file'] );
+ return;
+ }
+
+ push @{$self->{_data}}, $obj;
+
+ return $obj;
+}
+
+=head2 $tar->error( [$BOOL] )
+
+Returns the current errorstring (usually, the last error reported).
+If a true value was specified, it will give the C<Carp::longmess>
+equivalent of the error, in effect giving you a stacktrace.
+
+For backwards compatibility, this error is also available as
+C<$Archive::Tar::error> although it is much recommended you use the
+method call instead.
+
+=cut
+
+{
+ $error = '';
+ my $longmess;
+
+ sub _error {
+ my $self = shift;
+ my $msg = $error = shift;
+ $longmess = Carp::longmess($error);
+ if (ref $self) {
+ $self->{_error} = $error;
+ $self->{_longmess} = $longmess;
+ }
+
+ ### set Archive::Tar::WARN to 0 to disable printing
+ ### of errors
+ if( $WARN ) {
+ carp $DEBUG ? $longmess : $msg;
+ }
+
+ return;
+ }
+
+ sub error {
+ my $self = shift;
+ if (ref $self) {
+ return shift() ? $self->{_longmess} : $self->{_error};
+ } else {
+ return shift() ? $longmess : $error;
+ }
+ }
+}
+
+=head2 $tar->setcwd( $cwd );
+
+C<Archive::Tar> needs to know the current directory, and it will run
+C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
+tarfile and saves it in the file system. (As of version 1.30, however,
+C<Archive::Tar> will use the speed optimization described below
+automatically, so it's only relevant if you're using C<extract_file()>).
+
+Since C<Archive::Tar> doesn't change the current directory internally
+while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
+can be avoided if we can guarantee that the current directory doesn't
+get changed externally.
+
+To use this performance boost, set the current directory via
+
+ use Cwd;
+ $tar->setcwd( cwd() );
+
+once before calling a function like C<extract_file> and
+C<Archive::Tar> will use the current directory setting from then on
+and won't call C<Cwd::cwd()> internally.
+
+To switch back to the default behaviour, use
+
+ $tar->setcwd( undef );
+
+and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
+
+If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
+be called for you.
+
+=cut
+
+sub setcwd {
+ my $self = shift;
+ my $cwd = shift;
+
+ $self->{cwd} = $cwd;
+}
+
+=head1 Class Methods
+
+=head2 Archive::Tar->create_archive($file, $compressed, @filelist)
+
+Creates a tar file from the list of files provided. The first
+argument can either be the name of the tar file to create or a
+reference to an open file handle (e.g. a GLOB reference).
+
+The second argument is used to indicate compression. You can either
+compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
+to be the C<gzip> compression level (between 1 and 9), but the use of
+constants is prefered:
+
+ # write a gzip compressed file
+ Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist );
+
+ # write a bzip compressed file
+ Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist );
+
+Note that when you pass in a filehandle, the compression argument
+is ignored, as all files are printed verbatim to your filehandle.
+If you wish to enable compression with filehandles, use an
+C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
+
+The remaining arguments list the files to be included in the tar file.
+These files must all exist. Any files which don't exist or can't be
+read are silently ignored.
+
+If the archive creation fails for any reason, C<create_archive> will
+return false. Please use the C<error> method to find the cause of the
+failure.
+
+Note that this method does not write C<on the fly> as it were; it
+still reads all the files into memory before writing out the archive.
+Consult the FAQ below if this is a problem.
+
+=cut
+
+sub create_archive {
+ my $class = shift;
+
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+ my @files = @_;
+
+ unless( @files ) {
+ return $class->_error( qq[Cowardly refusing to create empty archive!] );
+ }
+
+ my $tar = $class->new;
+ $tar->add_files( @files );
+ return $tar->write( $file, $gzip );
+}
+
+=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] )
+
+Returns an iterator function that reads the tar file without loading
+it all in memory. Each time the function is called it will return the
+next file in the tarball. The files are returned as
+C<Archive::Tar::File> objects. The iterator function returns the
+empty list once it has exhausted the files contained.
+
+The second argument can be a hash reference with options, which are
+identical to the arguments passed to C<read()>.
+
+Example usage:
+
+ my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} );
+
+ while( my $f = $next->() ) {
+ print $f->name, "\n";
+
+ $f->extract or warn "Extraction failed";
+
+ # ....
+ }
+
+=cut
+
+
+sub iter {
+ my $class = shift;
+ my $filename = shift or return;
+ my $compressed = shift or 0;
+ my $opts = shift || {};
+
+ ### get a handle to read from.
+ my $handle = $class->_get_handle(
+ $filename,
+ $compressed,
+ READ_ONLY->( ZLIB )
+ ) or return;
+
+ my @data;
+ return sub {
+ return shift(@data) if @data; # more than one file returned?
+ return unless $handle; # handle exhausted?
+
+ ### read data, should only return file
+ my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 });
+ @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY';
+
+ ### return one piece of data
+ return shift(@data) if @data;
+
+ ### data is exhausted, free the filehandle
+ undef $handle;
+ return;
+ };
+}
+
+=head2 Archive::Tar->list_archive($file, $compressed, [\@properties])
+
+Returns a list of the names of all the files in the archive. The
+first argument can either be the name of the tar file to list or a
+reference to an open file handle (e.g. a GLOB reference).
+
+If C<list_archive()> is passed an array reference as its third
+argument it returns a list of hash references containing the requested
+properties of each file. The following list of properties is
+supported: full_path, name, size, mtime (last modified date), mode,
+uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
+
+See C<Archive::Tar::File> for details about supported properties.
+
+Passing an array reference containing only one element, 'name', is
+special cased to return a list of names rather than a list of hash
+references.
+
+=cut
+
+sub list_archive {
+ my $class = shift;
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+
+ my $tar = $class->new($file, $gzip);
+ return unless $tar;
+
+ return $tar->list_files( @_ );
+}
+
+=head2 Archive::Tar->extract_archive($file, $compressed)
+
+Extracts the contents of the tar file. The first argument can either
+be the name of the tar file to create or a reference to an open file
+handle (e.g. a GLOB reference). All relative paths in the tar file will
+be created underneath the current working directory.
+
+C<extract_archive> will return a list of files it extracted.
+If the archive extraction fails for any reason, C<extract_archive>
+will return false. Please use the C<error> method to find the cause
+of the failure.
+
+=cut
+
+sub extract_archive {
+ my $class = shift;
+ my $file = shift; return unless defined $file;
+ my $gzip = shift || 0;
+
+ my $tar = $class->new( ) or return;
+
+ return $tar->read( $file, $gzip, { extract => 1 } );
+}
+
+=head2 $bool = Archive::Tar->has_io_string
+
+Returns true if we currently have C<IO::String> support loaded.
+
+Either C<IO::String> or C<perlio> support is needed to support writing
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_io_string { return $HAS_IO_STRING; }
+
+=head2 $bool = Archive::Tar->has_perlio
+
+Returns true if we currently have C<perlio> support loaded.
+
+This requires C<perl-5.8> or higher, compiled with C<perlio>
+
+Either C<IO::String> or C<perlio> support is needed to support writing
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_perlio { return $HAS_PERLIO; }
+
+=head2 $bool = Archive::Tar->has_zlib_support
+
+Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
+
+=cut
+
+sub has_zlib_support { return ZLIB }
+
+=head2 $bool = Archive::Tar->has_bzip2_support
+
+Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
+
+=cut
+
+sub has_bzip2_support { return BZIP }
+
+=head2 Archive::Tar->can_handle_compressed_files
+
+A simple checking routine, which will return true if C<Archive::Tar>
+is able to uncompress compressed archives on the fly with C<IO::Zlib>
+and C<IO::Compress::Bzip2> or false if not both are installed.
+
+You can use this as a shortcut to determine whether C<Archive::Tar>
+will do what you think before passing compressed archives to its
+C<read> method.
+
+=cut
+
+sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 }
+
+sub no_string_support {
+ croak("You have to install IO::String to support writing archives to strings");
+}
+
+1;
+
+__END__
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Archive::Tar::FOLLOW_SYMLINK
+
+Set this variable to C<1> to make C<Archive::Tar> effectively make a
+copy of the file when extracting. Default is C<0>, which
+means the symlink stays intact. Of course, you will have to pack the
+file linked to as well.
+
+This option is checked when you write out the tarfile using C<write>
+or C<create_archive>.
+
+This works just like C</bin/tar>'s C<-h> option.
+
+=head2 $Archive::Tar::CHOWN
+
+By default, C<Archive::Tar> will try to C<chown> your files if it is
+able to. In some cases, this may not be desired. In that case, set
+this variable to C<0> to disable C<chown>-ing, even if it were
+possible.
+
+The default is C<1>.
+
+=head2 $Archive::Tar::CHMOD
+
+By default, C<Archive::Tar> will try to C<chmod> your files to
+whatever mode was specified for the particular file in the archive.
+In some cases, this may not be desired. In that case, set this
+variable to C<0> to disable C<chmod>-ing.
+
+The default is C<1>.
+
+=head2 $Archive::Tar::SAME_PERMISSIONS
+
+When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether
+the permissions on files from the archive are used without modification
+of if they are filtered by removing any setid bits and applying the
+current umask.
+
+The default is C<1> for the root user and C<0> for normal users.
+
+=head2 $Archive::Tar::DO_NOT_USE_PREFIX
+
+By default, C<Archive::Tar> will try to put paths that are over
+100 characters in the C<prefix> field of your tar header, as
+defined per POSIX-standard. However, some (older) tar programs
+do not implement this spec. To retain compatibility with these older
+or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
+variable to a true value, and C<Archive::Tar> will use an alternate
+way of dealing with paths over 100 characters by using the
+C<GNU Extended Header> feature.
+
+Note that clients who do not support the C<GNU Extended Header>
+feature will not be able to read these archives. Such clients include
+tars on C<Solaris>, C<Irix> and C<AIX>.
+
+The default is C<0>.
+
+=head2 $Archive::Tar::DEBUG
+
+Set this variable to C<1> to always get the C<Carp::longmess> output
+of the warnings, instead of the regular C<carp>. This is the same
+message you would get by doing:
+
+ $tar->error(1);
+
+Defaults to C<0>.
+
+=head2 $Archive::Tar::WARN
+
+Set this variable to C<0> if you do not want any warnings printed.
+Personally I recommend against doing this, but people asked for the
+option. Also, be advised that this is of course not threadsafe.
+
+Defaults to C<1>.
+
+=head2 $Archive::Tar::error
+
+Holds the last reported error. Kept for historical reasons, but its
+use is very much discouraged. Use the C<error()> method instead:
+
+ warn $tar->error unless $tar->extract;
+
+Note that in older versions of this module, the C<error()> method
+would return an effectively global value even when called an instance
+method as above. This has since been fixed, and multiple instances of
+C<Archive::Tar> now have separate error strings.
+
+=head2 $Archive::Tar::INSECURE_EXTRACT_MODE
+
+This variable indicates whether C<Archive::Tar> should allow
+files to be extracted outside their current working directory.
+
+Allowing this could have security implications, as a malicious
+tar archive could alter or replace any file the extracting user
+has permissions to. Therefor, the default is to not allow
+insecure extractions.
+
+If you trust the archive, or have other reasons to allow the
+archive to write files outside your current working directory,
+set this variable to C<true>.
+
+Note that this is a backwards incompatible change from version
+C<1.36> and before.
+
+=head2 $Archive::Tar::HAS_PERLIO
+
+This variable holds a boolean indicating if we currently have
+C<perlio> support loaded. This will be enabled for any perl
+greater than C<5.8> compiled with C<perlio>.
+
+If you feel strongly about disabling it, set this variable to
+C<false>. Note that you will then need C<IO::String> installed
+to support writing stringified archives.
+
+Don't change this variable unless you B<really> know what you're
+doing.
+
+=head2 $Archive::Tar::HAS_IO_STRING
+
+This variable holds a boolean indicating if we currently have
+C<IO::String> support loaded. This will be enabled for any perl
+that has a loadable C<IO::String> module.
+
+If you feel strongly about disabling it, set this variable to
+C<false>. Note that you will then need C<perlio> support from
+your perl to be able to write stringified archives.
+
+Don't change this variable unless you B<really> know what you're
+doing.
+
+=head1 FAQ
+
+=over 4
+
+=item What's the minimum perl version required to run Archive::Tar?
+
+You will need perl version 5.005_03 or newer.
+
+=item Isn't Archive::Tar slow?
+
+Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
+However, it's very portable. If speed is an issue, consider using
+C</bin/tar> instead.
+
+=item Isn't Archive::Tar heavier on memory than /bin/tar?
+
+Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
+C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
+choice but to read the archive into memory.
+This is ok if you want to do in-memory manipulation of the archive.
+
+If you just want to extract, use the C<extract_archive> class method
+instead. It will optimize and write to disk immediately.
+
+Another option is to use the C<iter> class method to iterate over
+the files in the tarball without reading them all in memory at once.
+
+=item Can you lazy-load data instead?
+
+In some cases, yes. You can use the C<iter> class method to iterate
+over the files in the tarball without reading them all in memory at once.
+
+=item How much memory will an X kb tar file need?
+
+Probably more than X kb, since it will all be read into memory. If
+this is a problem, and you don't need to do in memory manipulation
+of the archive, consider using the C<iter> class method, or C</bin/tar>
+instead.
+
+=item What do you do with unsupported filetypes in an archive?
+
+C<Unix> has a few filetypes that aren't supported on other platforms,
+like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
+try to make a copy of the original file, rather than throwing an error.
+
+This does require you to read the entire archive in to memory first,
+since otherwise we wouldn't know what data to fill the copy with.
+(This means that you cannot use the class methods, including C<iter>
+on archives that have incompatible filetypes and still expect things
+to work).
+
+For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
+the extraction of this particular item didn't work.
+
+=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
+
+By default, C<Archive::Tar> is in a completely POSIX-compatible
+mode, which uses the POSIX-specification of C<tar> to store files.
+For paths greather than 100 characters, this is done using the
+C<POSIX header prefix>. Non-POSIX-compatible clients may not support
+this part of the specification, and may only support the C<GNU Extended
+Header> functionality. To facilitate those clients, you can set the
+C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
+C<GLOBAL VARIABLES> section for details on this variable.
+
+Note that GNU tar earlier than version 1.14 does not cope well with
+the C<POSIX header prefix>. If you use such a version, consider setting
+the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
+
+=item How do I extract only files that have property X from an archive?
+
+Sometimes, you might not wish to extract a complete archive, just
+the files that are relevant to you, based on some criteria.
+
+You can do this by filtering a list of C<Archive::Tar::File> objects
+based on your criteria. For example, to extract only files that have
+the string C<foo> in their title, you would use:
+
+ $tar->extract(
+ grep { $_->full_path =~ /foo/ } $tar->get_files
+ );
+
+This way, you can filter on any attribute of the files in the archive.
+Consult the C<Archive::Tar::File> documentation on how to use these
+objects.
+
+=item How do I access .tar.Z files?
+
+The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
+the C<IO::Zlib> module) to access tar files that have been compressed
+with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
+utility cannot be read by C<Compress::Zlib> and so cannot be directly
+accesses by C<Archive::Tar>.
+
+If the C<uncompress> or C<gunzip> programs are available, you can use
+one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
+
+Firstly with C<uncompress>
+
+ use Archive::Tar;
+
+ open F, "uncompress -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+and this with C<gunzip>
+
+ use Archive::Tar;
+
+ open F, "gunzip -c $filename |";
+ my $tar = Archive::Tar->new(*F);
+ ...
+
+Similarly, if the C<compress> program is available, you can use this to
+write a C<.tar.Z> file
+
+ use Archive::Tar;
+ use IO::File;
+
+ my $fh = new IO::File "| compress -c >$filename";
+ my $tar = Archive::Tar->new();
+ ...
+ $tar->write($fh);
+ $fh->close ;
+
+=item How do I handle Unicode strings?
+
+C<Archive::Tar> uses byte semantics for any files it reads from or writes
+to disk. This is not a problem if you only deal with files and never
+look at their content or work solely with byte strings. But if you use
+Unicode strings with character semantics, some additional steps need
+to be taken.
+
+For example, if you add a Unicode string like
+
+ # Problem
+ $tar->add_data('file.txt', "Euro: \x{20AC}");
+
+then there will be a problem later when the tarfile gets written out
+to disk via C<$tar->write()>:
+
+ Wide character in print at .../Archive/Tar.pm line 1014.
+
+The data was added as a Unicode string and when writing it out to disk,
+the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
+tried to convert the string to ISO-8859 and failed. The written file
+now contains garbage.
+
+For this reason, Unicode strings need to be converted to UTF-8-encoded
+bytestrings before they are handed off to C<add_data()>:
+
+ use Encode;
+ my $data = "Accented character: \x{20AC}";
+ $data = encode('utf8', $data);
+
+ $tar->add_data('file.txt', $data);
+
+A opposite problem occurs if you extract a UTF8-encoded file from a
+tarball. Using C<get_content()> on the C<Archive::Tar::File> object
+will return its content as a bytestring, not as a Unicode string.
+
+If you want it to be a Unicode string (because you want character
+semantics with operations like regular expression matching), you need
+to decode the UTF8-encoded content and have Perl convert it into
+a Unicode string:
+
+ use Encode;
+ my $data = $tar->get_content();
+
+ # Make it a Unicode string
+ $data = decode('utf8', $data);
+
+There is no easy way to provide this functionality in C<Archive::Tar>,
+because a tarball can contain many files, and each of which could be
+encoded in a different way.
+
+=back
+
+=head1 CAVEATS
+
+The AIX tar does not fill all unused space in the tar archive with 0x00.
+This sometimes leads to warning messages from C<Archive::Tar>.
+
+ Invalid header block at offset nnn
+
+A fix for that problem is scheduled to be released in the following levels
+of AIX, all of which should be coming out in the 4th quarter of 2009:
+
+ AIX 5.3 TL7 SP10
+ AIX 5.3 TL8 SP8
+ AIX 5.3 TL9 SP5
+ AIX 5.3 TL10 SP2
+
+ AIX 6.1 TL0 SP11
+ AIX 6.1 TL1 SP7
+ AIX 6.1 TL2 SP6
+ AIX 6.1 TL3 SP3
+
+The IBM APAR number for this problem is IZ50240 (Reported component ID:
+5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
+If you need an ifix please contact your local IBM AIX support.
+
+=head1 TODO
+
+=over 4
+
+=item Check if passed in handles are open for read/write
+
+Currently I don't know of any portable pure perl way to do this.
+Suggestions welcome.
+
+=item Allow archives to be passed in as string
+
+Currently, we only allow opened filehandles or filenames, but
+not strings. The internals would need some reworking to facilitate
+stringified archives.
+
+=item Facilitate processing an opened filehandle of a compressed archive
+
+Currently, we only support this if the filehandle is an IO::Zlib object.
+Environments, like apache, will present you with an opened filehandle
+to an uploaded file, which might be a compressed archive.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item The GNU tar specification
+
+C<http://www.gnu.org/software/tar/manual/tar.html>
+
+=item The PAX format specication
+
+The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
+
+=item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
+
+=item GNU tar intends to switch to POSIX compatibility
+
+GNU Tar authors have expressed their intention to become completely
+POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
+
+=item A Comparison between various tar implementations
+
+Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
+
+=back
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas,
+Rainer Tammer and especially Andrew Savige for their help and suggestions.
+
+=head1 COPYRIGHT
+
+This module is copyright (c) 2002 - 2009 Jos Boumans
+E<lt>kane@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.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
new file mode 100644
index 00000000000..aef1d623fa8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
@@ -0,0 +1,86 @@
+package Archive::Tar::Constant;
+
+BEGIN {
+ require Exporter;
+
+ $VERSION = '0.02';
+ @ISA = qw[Exporter];
+
+ require Time::Local if $^O eq "MacOS";
+}
+
+use Package::Constants;
+@EXPORT = Package::Constants->list( __PACKAGE__ );
+
+use constant FILE => 0;
+use constant HARDLINK => 1;
+use constant SYMLINK => 2;
+use constant CHARDEV => 3;
+use constant BLOCKDEV => 4;
+use constant DIR => 5;
+use constant FIFO => 6;
+use constant SOCKET => 8;
+use constant UNKNOWN => 9;
+use constant LONGLINK => 'L';
+use constant LABEL => 'V';
+
+use constant BUFFER => 4096;
+use constant HEAD => 512;
+use constant BLOCK => 512;
+
+use constant COMPRESS_GZIP => 9;
+use constant COMPRESS_BZIP => 'bzip2';
+
+use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
+use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
+use constant TAR_END => "\0" x BLOCK;
+
+use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
+use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
+use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
+
+# Pointless assignment to make -w shut up
+my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
+my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
+use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
+use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
+use constant UID => $>;
+use constant GID => (split ' ', $) )[0];
+
+use constant MODE => do { 0666 & (0777 & ~umask) };
+use constant STRIP_MODE => sub { shift() & 0777 };
+use constant CHECK_SUM => " ";
+
+use constant UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
+use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
+use constant NAME_LENGTH => 100;
+use constant PREFIX_LENGTH => 155;
+
+use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
+use constant MAGIC => "ustar";
+use constant TAR_VERSION => "00";
+use constant LONGLINK_NAME => '././@LongLink';
+use constant PAX_HEADER => 'pax_global_header';
+
+ ### allow ZLIB to be turned off using ENV: DEBUG only
+use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
+ eval { require IO::Zlib };
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
+ };
+
+ ### allow BZIP to be turned off using ENV: DEBUG only
+use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
+ eval { require IO::Uncompress::Bunzip2;
+ require IO::Compress::Bzip2; };
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
+ };
+
+use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
+use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
+
+use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
+use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
+use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
+use constant ON_VMS => $^O eq 'VMS';
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
new file mode 100644
index 00000000000..0815bb67620
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
@@ -0,0 +1,660 @@
+package Archive::Tar::File;
+use strict;
+
+use Carp ();
+use IO::File;
+use File::Spec::Unix ();
+use File::Spec ();
+use File::Basename ();
+
+### avoid circular use, so only require;
+require Archive::Tar;
+use Archive::Tar::Constant;
+
+use vars qw[@ISA $VERSION];
+#@ISA = qw[Archive::Tar];
+$VERSION = '0.02';
+
+### set value to 1 to oct() it during the unpack ###
+my $tmpl = [
+ name => 0, # string
+ mode => 1, # octal
+ uid => 1, # octal
+ gid => 1, # octal
+ size => 1, # octal
+ mtime => 1, # octal
+ chksum => 1, # octal
+ type => 0, # character
+ linkname => 0, # string
+ magic => 0, # string
+ version => 0, # 2 bytes
+ uname => 0, # string
+ gname => 0, # string
+ devmajor => 1, # octal
+ devminor => 1, # octal
+ prefix => 0,
+
+### end UNPACK items ###
+ raw => 0, # the raw data chunk
+ data => 0, # the data associated with the file --
+ # This might be very memory intensive
+];
+
+### install get/set accessors for this object.
+for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
+ my $key = $tmpl->[$i];
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+
+ ### just in case the key is not there or undef or something ###
+ { local $^W = 0;
+ return $self->{$key};
+ }
+ }
+}
+
+=head1 NAME
+
+Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
+
+=head1 SYNOPSIS
+
+ my @items = $tar->get_files;
+
+ print $_->name, ' ', $_->size, "\n" for @items;
+
+ print $object->get_content;
+ $object->replace_content('new content');
+
+ $object->rename( 'new/full/path/to/file.c' );
+
+=head1 DESCRIPTION
+
+Archive::Tar::Files provides a neat little object layer for in-memory
+extracted files. It's mostly used internally in Archive::Tar to tidy
+up the code, but there's no reason users shouldn't use this API as
+well.
+
+=head2 Accessors
+
+A lot of the methods in this package are accessors to the various
+fields in the tar header:
+
+=over 4
+
+=item name
+
+The file's name
+
+=item mode
+
+The file's mode
+
+=item uid
+
+The user id owning the file
+
+=item gid
+
+The group id owning the file
+
+=item size
+
+File size in bytes
+
+=item mtime
+
+Modification time. Adjusted to mac-time on MacOS if required
+
+=item chksum
+
+Checksum field for the tar header
+
+=item type
+
+File type -- numeric, but comparable to exported constants -- see
+Archive::Tar's documentation
+
+=item linkname
+
+If the file is a symlink, the file it's pointing to
+
+=item magic
+
+Tar magic string -- not useful for most users
+
+=item version
+
+Tar version string -- not useful for most users
+
+=item uname
+
+The user name that owns the file
+
+=item gname
+
+The group name that owns the file
+
+=item devmajor
+
+Device major number in case of a special file
+
+=item devminor
+
+Device minor number in case of a special file
+
+=item prefix
+
+Any directory to prefix to the extraction path, if any
+
+=item raw
+
+Raw tar header -- not useful for most users
+
+=back
+
+=head1 Methods
+
+=head2 Archive::Tar::File->new( file => $path )
+
+Returns a new Archive::Tar::File object from an existing file.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( data => $path, $data, $opt )
+
+Returns a new Archive::Tar::File object from data.
+
+C<$path> defines the file name (which need not exist), C<$data> the
+file contents, and C<$opt> is a reference to a hash of attributes
+which may be used to override the default attributes (fields in the
+tar header), which are described above in the Accessors section.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( chunk => $chunk )
+
+Returns a new Archive::Tar::File object from a raw 512-byte tar
+archive chunk.
+
+Returns undef on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $what = shift;
+
+ my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
+ ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
+ ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
+ undef;
+
+ return $obj;
+}
+
+### copies the data, creates a clone ###
+sub clone {
+ my $self = shift;
+ return bless { %$self }, ref $self;
+}
+
+sub _new_from_chunk {
+ my $class = shift;
+ my $chunk = shift or return; # 512 bytes of tar header
+ my %hash = @_;
+
+ ### filter any arguments on defined-ness of values.
+ ### this allows overriding from what the tar-header is saying
+ ### about this tar-entry. Particularly useful for @LongLink files
+ my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
+
+ ### makes it start at 0 actually... :) ###
+ my $i = -1;
+ my %entry = map {
+ $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
+ } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
+
+ my $obj = bless { %entry, %args }, $class;
+
+ ### magic is a filetype string.. it should have something like 'ustar' or
+ ### something similar... if the chunk is garbage, skip it
+ return unless $obj->magic !~ /\W/;
+
+ ### store the original chunk ###
+ $obj->raw( $chunk );
+
+ $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
+ $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
+
+
+ return $obj;
+
+}
+
+sub _new_from_file {
+ my $class = shift;
+ my $path = shift;
+
+ ### path has to at least exist
+ return unless defined $path;
+
+ my $type = __PACKAGE__->_filetype($path);
+ my $data = '';
+
+ READ: {
+ unless ($type == DIR ) {
+ my $fh = IO::File->new;
+
+ unless( $fh->open($path) ) {
+ ### dangling symlinks are fine, stop reading but continue
+ ### creating the object
+ last READ if $type == SYMLINK;
+
+ ### otherwise, return from this function --
+ ### anything that's *not* a symlink should be
+ ### resolvable
+ return;
+ }
+
+ ### binmode needed to read files properly on win32 ###
+ binmode $fh;
+ $data = do { local $/; <$fh> };
+ close $fh;
+ }
+ }
+
+ my @items = qw[mode uid gid size mtime];
+ my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
+
+ if (ON_VMS) {
+ ### VMS has two UID modes, traditional and POSIX. Normally POSIX is
+ ### not used. We currently do not have an easy way to see if we are in
+ ### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
+ ### The VMS UIC has the upper 16 bits is the GID, which in many cases
+ ### the VMS UIC will be larger than 209715, the largest that TAR can
+ ### handle. So for now, assume it is traditional if the UID is larger
+ ### than 0x10000.
+
+ if ($hash{uid} > 0x10000) {
+ $hash{uid} = $hash{uid} & 0xFFFF;
+ }
+
+ ### The file length from stat() is the physical length of the file
+ ### However the amount of data read in may be more for some file types.
+ ### Fixed length files are read past the logical EOF to end of the block
+ ### containing. Other file types get expanded on read because record
+ ### delimiters are added.
+
+ my $data_len = length $data;
+ $hash{size} = $data_len if $hash{size} < $data_len;
+
+ }
+ ### you *must* set size == 0 on symlinks, or the next entry will be
+ ### though of as the contents of the symlink, which is wrong.
+ ### this fixes bug #7937
+ $hash{size} = 0 if ($type == DIR or $type == SYMLINK);
+ $hash{mtime} -= TIME_OFFSET;
+
+ ### strip the high bits off the mode, which we don't need to store
+ $hash{mode} = STRIP_MODE->( $hash{mode} );
+
+
+ ### probably requires some file path munging here ... ###
+ ### name and prefix are set later
+ my $obj = {
+ %hash,
+ name => '',
+ chksum => CHECK_SUM,
+ type => $type,
+ linkname => ($type == SYMLINK and CAN_READLINK)
+ ? readlink $path
+ : '',
+ magic => MAGIC,
+ version => TAR_VERSION,
+ uname => UNAME->( $hash{uid} ),
+ gname => GNAME->( $hash{gid} ),
+ devmajor => 0, # not handled
+ devminor => 0, # not handled
+ prefix => '',
+ data => $data,
+ };
+
+ bless $obj, $class;
+
+ ### fix up the prefix and file from the path
+ my($prefix,$file) = $obj->_prefix_and_file( $path );
+ $obj->prefix( $prefix );
+ $obj->name( $file );
+
+ return $obj;
+}
+
+sub _new_from_data {
+ my $class = shift;
+ my $path = shift; return unless defined $path;
+ my $data = shift; return unless defined $data;
+ my $opt = shift;
+
+ my $obj = {
+ data => $data,
+ name => '',
+ mode => MODE,
+ uid => UID,
+ gid => GID,
+ size => length $data,
+ mtime => time - TIME_OFFSET,
+ chksum => CHECK_SUM,
+ type => FILE,
+ linkname => '',
+ magic => MAGIC,
+ version => TAR_VERSION,
+ uname => UNAME->( UID ),
+ gname => GNAME->( GID ),
+ devminor => 0,
+ devmajor => 0,
+ prefix => '',
+ };
+
+ ### overwrite with user options, if provided ###
+ if( $opt and ref $opt eq 'HASH' ) {
+ for my $key ( keys %$opt ) {
+
+ ### don't write bogus options ###
+ next unless exists $obj->{$key};
+ $obj->{$key} = $opt->{$key};
+ }
+ }
+
+ bless $obj, $class;
+
+ ### fix up the prefix and file from the path
+ my($prefix,$file) = $obj->_prefix_and_file( $path );
+ $obj->prefix( $prefix );
+ $obj->name( $file );
+
+ return $obj;
+}
+
+sub _prefix_and_file {
+ my $self = shift;
+ my $path = shift;
+
+ my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
+ my @dirs = File::Spec->splitdir( $dirs );
+
+ ### so sometimes the last element is '' -- probably when trailing
+ ### dir slashes are encountered... this is of course pointless,
+ ### so remove it
+ pop @dirs while @dirs and not length $dirs[-1];
+
+ ### if it's a directory, then $file might be empty
+ $file = pop @dirs if $self->is_dir and not length $file;
+
+ ### splitting ../ gives you the relative path in native syntax
+ map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS;
+
+ my $prefix = File::Spec::Unix->catdir(
+ grep { length } $vol, @dirs
+ );
+ return( $prefix, $file );
+}
+
+sub _filetype {
+ my $self = shift;
+ my $file = shift;
+
+ return unless defined $file;
+
+ return SYMLINK if (-l $file); # Symlink
+
+ return FILE if (-f _); # Plain file
+
+ return DIR if (-d _); # Directory
+
+ return FIFO if (-p _); # Named pipe
+
+ return SOCKET if (-S _); # Socket
+
+ return BLOCKDEV if (-b _); # Block special
+
+ return CHARDEV if (-c _); # Character special
+
+ ### shouldn't happen, this is when making archives, not reading ###
+ return LONGLINK if ( $file eq LONGLINK_NAME );
+
+ return UNKNOWN; # Something else (like what?)
+
+}
+
+### this method 'downgrades' a file to plain file -- this is used for
+### symlinks when FOLLOW_SYMLINKS is true.
+sub _downgrade_to_plainfile {
+ my $entry = shift;
+ $entry->type( FILE );
+ $entry->mode( MODE );
+ $entry->linkname('');
+
+ return 1;
+}
+
+=head2 $bool = $file->extract( [ $alternative_name ] )
+
+Extract this object, optionally to an alternative name.
+
+See C<< Archive::Tar->extract_file >> for details.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub extract {
+ my $self = shift;
+
+ local $Carp::CarpLevel += 1;
+
+ return Archive::Tar->_extract_file( $self, @_ );
+}
+
+=head2 $path = $file->full_path
+
+Returns the full path from the tar header; this is basically a
+concatenation of the C<prefix> and C<name> fields.
+
+=cut
+
+sub full_path {
+ my $self = shift;
+
+ ### if prefix field is emtpy
+ return $self->name unless defined $self->prefix and length $self->prefix;
+
+ ### or otherwise, catfile'd
+ return File::Spec::Unix->catfile( $self->prefix, $self->name );
+}
+
+
+=head2 $bool = $file->validate
+
+Done by Archive::Tar internally when reading the tar file:
+validate the header against the checksum to ensure integer tar file.
+
+Returns true on success, false on failure
+
+=cut
+
+sub validate {
+ my $self = shift;
+
+ my $raw = $self->raw;
+
+ ### don't know why this one is different from the one we /write/ ###
+ substr ($raw, 148, 8) = " ";
+
+ ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
+ ### like GNU tar does. See here for details:
+ ### http://www.gnu.org/software/tar/manual/tar.html#SEC139
+ ### so we do both a signed AND unsigned validate. if one succeeds, that's
+ ### good enough
+ return ( (unpack ("%16C*", $raw) == $self->chksum)
+ or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
+}
+
+=head2 $bool = $file->has_content
+
+Returns a boolean to indicate whether the current object has content.
+Some special files like directories and so on never will have any
+content. This method is mainly to make sure you don't get warnings
+for using uninitialized values when looking at an object's content.
+
+=cut
+
+sub has_content {
+ my $self = shift;
+ return defined $self->data() && length $self->data() ? 1 : 0;
+}
+
+=head2 $content = $file->get_content
+
+Returns the current content for the in-memory file
+
+=cut
+
+sub get_content {
+ my $self = shift;
+ $self->data( );
+}
+
+=head2 $cref = $file->get_content_by_ref
+
+Returns the current content for the in-memory file as a scalar
+reference. Normal users won't need this, but it will save memory if
+you are dealing with very large data files in your tar archive, since
+it will pass the contents by reference, rather than make a copy of it
+first.
+
+=cut
+
+sub get_content_by_ref {
+ my $self = shift;
+
+ return \$self->{data};
+}
+
+=head2 $bool = $file->replace_content( $content )
+
+Replace the current content of the file with the new content. This
+only affects the in-memory archive, not the on-disk version until
+you write it.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub replace_content {
+ my $self = shift;
+ my $data = shift || '';
+
+ $self->data( $data );
+ $self->size( length $data );
+ return 1;
+}
+
+=head2 $bool = $file->rename( $new_name )
+
+Rename the current file to $new_name.
+
+Note that you must specify a Unix path for $new_name, since per tar
+standard, all files in the archive must be Unix paths.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub rename {
+ my $self = shift;
+ my $path = shift;
+
+ return unless defined $path;
+
+ my ($prefix,$file) = $self->_prefix_and_file( $path );
+
+ $self->name( $file );
+ $self->prefix( $prefix );
+
+ return 1;
+}
+
+=head1 Convenience methods
+
+To quickly check the type of a C<Archive::Tar::File> object, you can
+use the following methods:
+
+=over 4
+
+=item $file->is_file
+
+Returns true if the file is of type C<file>
+
+=item $file->is_dir
+
+Returns true if the file is of type C<dir>
+
+=item $file->is_hardlink
+
+Returns true if the file is of type C<hardlink>
+
+=item $file->is_symlink
+
+Returns true if the file is of type C<symlink>
+
+=item $file->is_chardev
+
+Returns true if the file is of type C<chardev>
+
+=item $file->is_blockdev
+
+Returns true if the file is of type C<blockdev>
+
+=item $file->is_fifo
+
+Returns true if the file is of type C<fifo>
+
+=item $file->is_socket
+
+Returns true if the file is of type C<socket>
+
+=item $file->is_longlink
+
+Returns true if the file is of type C<LongLink>.
+Should not happen after a successful C<read>.
+
+=item $file->is_label
+
+Returns true if the file is of type C<Label>.
+Should not happen after a successful C<read>.
+
+=item $file->is_unknown
+
+Returns true if the file type is C<unknown>
+
+=back
+
+=cut
+
+#stupid perl5.5.3 needs to warn if it's not numeric
+sub is_file { local $^W; FILE == $_[0]->type }
+sub is_dir { local $^W; DIR == $_[0]->type }
+sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
+sub is_symlink { local $^W; SYMLINK == $_[0]->type }
+sub is_chardev { local $^W; CHARDEV == $_[0]->type }
+sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
+sub is_fifo { local $^W; FIFO == $_[0]->type }
+sub is_socket { local $^W; SOCKET == $_[0]->type }
+sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
+sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
+sub is_label { local $^W; LABEL eq $_[0]->type }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Attribute/Handlers.pm b/Master/tlpkg/tlperl/lib/Attribute/Handlers.pm
new file mode 100644
index 00000000000..ea11b8f7ed6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Attribute/Handlers.pm
@@ -0,0 +1,924 @@
+package Attribute::Handlers;
+use 5.006;
+use Carp;
+use warnings;
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = '0.87'; # remember to update version in POD!
+# $DB::single=1;
+
+my %symcache;
+sub findsym {
+ my ($pkg, $ref, $type) = @_;
+ return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
+ $type ||= ref($ref);
+ no strict 'refs';
+ foreach my $sym ( values %{$pkg."::"} ) {
+ use strict;
+ next unless ref ( \$sym ) eq 'GLOB';
+ return $symcache{$pkg,$ref} = \$sym
+ if *{$sym}{$type} && *{$sym}{$type} == $ref;
+ }
+}
+
+my %validtype = (
+ VAR => [qw[SCALAR ARRAY HASH]],
+ ANY => [qw[SCALAR ARRAY HASH CODE]],
+ "" => [qw[SCALAR ARRAY HASH CODE]],
+ SCALAR => [qw[SCALAR]],
+ ARRAY => [qw[ARRAY]],
+ HASH => [qw[HASH]],
+ CODE => [qw[CODE]],
+);
+my %lastattr;
+my @declarations;
+my %raw;
+my %phase;
+my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
+my $global_phase = 0;
+my %global_phases = (
+ BEGIN => 0,
+ CHECK => 1,
+ INIT => 2,
+ END => 3,
+);
+my @global_phases = qw(BEGIN CHECK INIT END);
+
+sub _usage_AH_ {
+ croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
+}
+
+my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
+
+sub import {
+ my $class = shift @_;
+ return unless $class eq "Attribute::Handlers";
+ while (@_) {
+ my $cmd = shift;
+ if ($cmd =~ /^autotie((?:ref)?)$/) {
+ my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
+ my $mapping = shift;
+ _usage_AH_ $class unless ref($mapping) eq 'HASH';
+ while (my($attr, $tieclass) = each %$mapping) {
+ $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
+ my $args = $3||'()';
+ _usage_AH_ $class unless $attr =~ $qual_id
+ && $tieclass =~ $qual_id
+ && eval "use base q\0$tieclass\0; 1";
+ if ($tieclass->isa('Exporter')) {
+ local $Exporter::ExportLevel = 2;
+ $tieclass->import(eval $args);
+ }
+ $attr =~ s/__CALLER__/caller(1)/e;
+ $attr = caller()."::".$attr unless $attr =~ /::/;
+ eval qq{
+ sub $attr : ATTR(VAR) {
+ my (\$ref, \$data) = \@_[2,4];
+ my \$was_arrayref = ref \$data eq 'ARRAY';
+ \$data = [ \$data ] unless \$was_arrayref;
+ my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
+ (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
+ :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
+ :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
+ : die "Can't autotie a \$type\n"
+ } 1
+ } or die "Internal error: $@";
+ }
+ }
+ else {
+ croak "Can't understand $_";
+ }
+ }
+}
+
+# On older perls, code attribute handlers run before the sub gets placed
+# in its package. Since the :ATTR handlers need to know the name of the
+# sub they're applied to, the name lookup (via findsym) needs to be
+# delayed: we do it immediately before we might need to find attribute
+# handlers from their name. However, on newer perls (which fix some
+# problems relating to attribute application), a sub gets placed in its
+# package before its attributes are processed. In this case, the
+# delayed name lookup might be too late, because the sub we're looking
+# for might have already been replaced. So we need to detect which way
+# round this perl does things, and time the name lookup accordingly.
+BEGIN {
+ my $delayed;
+ sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
+ $delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
+ return ();
+ }
+ sub Attribute::Handlers::_TEST_::t :T { }
+ *_delayed_name_resolution = sub() { $delayed };
+ undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
+ undef &Attribute::Handlers::_TEST_::t;
+}
+
+sub _resolve_lastattr {
+ return unless $lastattr{ref};
+ my $sym = findsym @lastattr{'pkg','ref'}
+ or die "Internal error: $lastattr{pkg} symbol went missing";
+ my $name = *{$sym}{NAME};
+ warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
+ if $^W and $name !~ /[A-Z]/;
+ foreach ( @{$validtype{$lastattr{type}}} ) {
+ no strict 'refs';
+ *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
+ }
+ %lastattr = ();
+}
+
+sub AUTOLOAD {
+ return if $AUTOLOAD =~ /::DESTROY$/;
+ my ($class) = $AUTOLOAD =~ m/(.*)::/g;
+ $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
+ croak "Can't locate class method '$AUTOLOAD' via package '$class'";
+ croak "Attribute handler '$2' doesn't handle $1 attributes";
+}
+
+my $builtin = qr/lvalue|method|locked|unique|shared/;
+
+sub _gen_handler_AH_() {
+ return sub {
+ _resolve_lastattr if _delayed_name_resolution;
+ my ($pkg, $ref, @attrs) = @_;
+ my (undef, $filename, $linenum) = caller 2;
+ foreach (@attrs) {
+ my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
+ if ($attr eq 'ATTR') {
+ no strict 'refs';
+ $data ||= "ANY";
+ $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
+ $phase{$ref}{BEGIN} = 1
+ if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
+ $phase{$ref}{INIT} = 1
+ if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
+ $phase{$ref}{END} = 1
+ if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
+ $phase{$ref}{CHECK} = 1
+ if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
+ || ! keys %{$phase{$ref}};
+ # Added for cleanup to not pollute next call.
+ (%lastattr = ()),
+ croak "Can't have two ATTR specifiers on one subroutine"
+ if keys %lastattr;
+ croak "Bad attribute type: ATTR($data)"
+ unless $validtype{$data};
+ %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
+ _resolve_lastattr unless _delayed_name_resolution;
+ }
+ else {
+ my $type = ref $ref;
+ my $handler = $pkg->can("_ATTR_${type}_${attr}");
+ next unless $handler;
+ my $decl = [$pkg, $ref, $attr, $data,
+ $raw{$handler}, $phase{$handler}, $filename, $linenum];
+ foreach my $gphase (@global_phases) {
+ _apply_handler_AH_($decl,$gphase)
+ if $global_phases{$gphase} <= $global_phase;
+ }
+ if ($global_phase != 0) {
+ # if _gen_handler_AH_ is being called after
+ # CHECK it's for a lexical, so make sure
+ # it didn't want to run anything later
+
+ local $Carp::CarpLevel = 2;
+ carp "Won't be able to apply END handler"
+ if $phase{$handler}{END};
+ }
+ else {
+ push @declarations, $decl
+ }
+ }
+ $_ = undef;
+ }
+ return grep {defined && !/$builtin/} @attrs;
+ }
+}
+
+{
+ no strict 'refs';
+ *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
+ _gen_handler_AH_ foreach @{$validtype{ANY}};
+}
+push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
+ unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
+
+sub _apply_handler_AH_ {
+ my ($declaration, $phase) = @_;
+ my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
+ return unless $handlerphase->{$phase};
+ # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
+ my $type = ref $ref;
+ my $handler = "_ATTR_${type}_${attr}";
+ my $sym = findsym($pkg, $ref);
+ $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
+ no warnings;
+ if (!$raw && defined($data)) {
+ if ($data ne '') {
+ my $evaled = eval("package $pkg; no warnings; no strict;
+ local \$SIG{__WARN__}=sub{die}; [$data]");
+ $data = $evaled unless $@;
+ }
+ else { $data = undef }
+ }
+ $pkg->$handler($sym,
+ (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
+ $attr,
+ $data,
+ $phase,
+ $filename,
+ $linenum,
+ );
+ return 1;
+}
+
+{
+ no warnings 'void';
+ CHECK {
+ $global_phase++;
+ _resolve_lastattr if _delayed_name_resolution;
+ _apply_handler_AH_($_,'CHECK') foreach @declarations;
+ }
+
+ INIT {
+ $global_phase++;
+ _apply_handler_AH_($_,'INIT') foreach @declarations
+ }
+}
+
+END { $global_phase++; _apply_handler_AH_($_,'END') foreach @declarations }
+
+1;
+__END__
+
+=head1 NAME
+
+Attribute::Handlers - Simpler definition of attribute handlers
+
+=head1 VERSION
+
+This document describes version 0.87 of Attribute::Handlers,
+released September 21, 2009.
+
+=head1 SYNOPSIS
+
+ package MyClass;
+ require 5.006;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ ...
+ }
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ ...
+ }
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ ...
+ }
+
+
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+
+=head1 DESCRIPTION
+
+This module, when inherited by a package, allows that package's class to
+define attribute handler subroutines for specific attributes. Variables
+and subroutines subsequently defined in that package, or in packages
+derived from that package may be given attributes with the same names as
+the attribute handler subroutines, which will then be called in one of
+the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
+block). (C<UNITCHECK> blocks don't correspond to a global compilation
+phase, so they can't be specified here.)
+
+To create a handler, define it as a subroutine with the same name as
+the desired attribute, and declare the subroutine itself with the
+attribute C<:ATTR>. For example:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ print STDERR
+ ref($referent), " ",
+ *{$symbol}{NAME}, " ",
+ "($referent) ", "was just declared ",
+ "and ascribed the ${attr} attribute ",
+ "with data ($data)\n",
+ "in phase $phase\n",
+ "in file $filename at line $linenum\n";
+ }
+
+This creates a handler for the attribute C<:Loud> in the class LoudDecl.
+Thereafter, any subroutine declared with a C<:Loud> attribute in the class
+LoudDecl:
+
+ package LoudDecl;
+
+ sub foo: Loud {...}
+
+causes the above handler to be invoked, and passed:
+
+=over
+
+=item [0]
+
+the name of the package into which it was declared;
+
+=item [1]
+
+a reference to the symbol table entry (typeglob) containing the subroutine;
+
+=item [2]
+
+a reference to the subroutine;
+
+=item [3]
+
+the name of the attribute;
+
+=item [4]
+
+any data associated with that attribute;
+
+=item [5]
+
+the name of the phase in which the handler is being invoked;
+
+=item [6]
+
+the filename in which the handler is being invoked;
+
+=item [7]
+
+the line number in this file.
+
+=back
+
+Likewise, declaring any variables with the C<:Loud> attribute within the
+package:
+
+ package LoudDecl;
+
+ my $foo :Loud;
+ my @foo :Loud;
+ my %foo :Loud;
+
+will cause the handler to be called with a similar argument list (except,
+of course, that C<$_[2]> will be a reference to the variable).
+
+The package name argument will typically be the name of the class into
+which the subroutine was declared, but it may also be the name of a derived
+class (since handlers are inherited).
+
+If a lexical variable is given an attribute, there is no symbol table to
+which it belongs, so the symbol table argument (C<$_[1]>) is set to the
+string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
+an anonymous subroutine results in a symbol table argument of C<'ANON'>.
+
+The data argument passes in the value (if any) associated with the
+attribute. For example, if C<&foo> had been declared:
+
+ sub foo :Loud("turn it up to 11, man!") {...}
+
+then a reference to an array containing the string
+C<"turn it up to 11, man!"> would be passed as the last argument.
+
+Attribute::Handlers makes strenuous efforts to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler (but see L<"Non-interpretive attribute handlers">).
+If those efforts succeed, the interpreted data is passed in an array
+reference; if they fail, the raw data is passed as a string.
+For example, all of these:
+
+ sub foo :Loud(till=>ears=>are=>bleeding) {...}
+ sub foo :Loud(qw/till ears are bleeding/) {...}
+ sub foo :Loud(qw/my, ears, are, bleeding/) {...}
+ sub foo :Loud(till,ears,are,bleeding) {...}
+
+causes it to pass C<['till','ears','are','bleeding']> as the handler's
+data argument. While:
+
+ sub foo :Loud(['till','ears','are','bleeding']) {...}
+
+causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
+reference specified in the data being passed inside the standard
+array reference indicating successful interpretation.
+
+However, if the data can't be parsed as valid Perl, then
+it is passed as an uninterpreted string. For example:
+
+ sub foo :Loud(my,ears,are,bleeding) {...}
+ sub foo :Loud(qw/my ears are bleeding) {...}
+
+cause the strings C<'my,ears,are,bleeding'> and
+C<'qw/my ears are bleeding'> respectively to be passed as the
+data argument.
+
+If no value is associated with the attribute, C<undef> is passed.
+
+=head2 Typed lexicals
+
+Regardless of the package in which it is declared, if a lexical variable is
+ascribed an attribute, the handler that is invoked is the one belonging to
+the package to which it is typed. For example, the following declarations:
+
+ package OtherClass;
+
+ my LoudDecl $loudobj : Loud;
+ my LoudDecl @loudobjs : Loud;
+ my LoudDecl %loudobjex : Loud;
+
+causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
+defines a handler for C<:Loud> attributes).
+
+
+=head2 Type-specific attribute handlers
+
+If an attribute handler is declared and the C<:ATTR> specifier is
+given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
+the handler is only applied to declarations of that type. For example,
+the following definition:
+
+ package LoudDecl;
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+
+creates an attribute handler that applies only to scalars:
+
+
+ package Painful;
+ use base LoudDecl;
+
+ my $metal : RealLoud; # invokes &LoudDecl::RealLoud
+ my @metal : RealLoud; # error: unknown attribute
+ my %metal : RealLoud; # error: unknown attribute
+ sub metal : RealLoud {...} # error: unknown attribute
+
+You can, of course, declare separate handlers for these types as well
+(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
+
+ package LoudDecl;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+ sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
+ sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
+ sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
+
+You can also explicitly indicate that a single handler is meant to be
+used for all types of referents like so:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
+
+(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
+
+
+=head2 Non-interpretive attribute handlers
+
+Occasionally the strenuous efforts Attribute::Handlers makes to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler get in the way.
+
+You can turn off that eagerness-to-help by declaring
+an attribute handler with the keyword C<RAWDATA>. For example:
+
+ sub Raw : ATTR(RAWDATA) {...}
+ sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
+ sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
+
+Then the handler makes absolutely no attempt to interpret the data it
+receives and simply passes it as a string:
+
+ my $power : Raw(1..100); # handlers receives "1..100"
+
+=head2 Phase-specific attribute handlers
+
+By default, attribute handlers are called at the end of the compilation
+phase (in a C<CHECK> block). This seems to be optimal in most cases because
+most things that can be defined are defined by that point but nothing has
+been executed.
+
+However, it is possible to set up attribute handlers that are called at
+other points in the program's compilation or execution, by explicitly
+stating the phase (or phases) in which you wish the attribute handler to
+be called. For example:
+
+ sub Early :ATTR(SCALAR,BEGIN) {...}
+ sub Normal :ATTR(SCALAR,CHECK) {...}
+ sub Late :ATTR(SCALAR,INIT) {...}
+ sub Final :ATTR(SCALAR,END) {...}
+ sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
+
+As the last example indicates, a handler may be set up to be (re)called in
+two or more phases. The phase name is passed as the handler's final argument.
+
+Note that attribute handlers that are scheduled for the C<BEGIN> phase
+are handled as soon as the attribute is detected (i.e. before any
+subsequently defined C<BEGIN> blocks are executed).
+
+
+=head2 Attributes as C<tie> interfaces
+
+Attributes make an excellent and intuitive interface through which to tie
+variables. For example:
+
+ use Attribute::Handlers;
+ use Tie::Cycle;
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+ tie $$referent, 'Tie::Cycle', $data;
+ }
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+ }
+
+Note that, because the C<Cycle> attribute receives its arguments in the
+C<$data> variable, if the attribute is given a list of arguments, C<$data>
+will consist of a single array reference; otherwise, it will consist of the
+single argument directly. Since Tie::Cycle requires its cycling values to
+be passed as an array reference, this means that we need to wrap
+non-array-reference arguments in an array constructor:
+
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+
+Typically, however, things are the other way around: the tieable class expects
+its arguments as a flattened list, so the attribute looks like:
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ my @data = ref $data eq 'ARRAY' ? @$data : $data;
+ tie $$referent, 'Tie::Whatever', @data;
+ }
+
+
+This software pattern is so widely applicable that Attribute::Handlers
+provides a way to automate it: specifying C<'autotie'> in the
+C<use Attribute::Handlers> statement. So, the cycling example,
+could also be written:
+
+ use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle(['A'..'Z']); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+
+Note that we now have to pass the cycling values as an array reference,
+since the C<autotie> mechanism passes C<tie> a list of arguments as a list
+(as in the Tie::Whatever example), I<not> as an array reference (as in
+the original Tie::Cycle example at the start of this section).
+
+The argument after C<'autotie'> is a reference to a hash in which each key is
+the name of an attribute to be created, and each value is the class to which
+variables ascribed that attribute should be tied.
+
+Note that there is no longer any need to import the Tie::Cycle module --
+Attribute::Handlers takes care of that automagically. You can even pass
+arguments to the module's C<import> subroutine, by appending them to the
+class name. For example:
+
+ use Attribute::Handlers
+ autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+If the attribute name is unqualified, the attribute is installed in the
+current package. Otherwise it is installed in the qualifier's package:
+
+ package Here;
+
+ use Attribute::Handlers autotie => {
+ Other::Good => Tie::SecureHash, # tie attr installed in Other::
+ Bad => Tie::Taxes, # tie attr installed in Here::
+ UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
+ };
+
+Autoties are most commonly used in the module to which they actually tie,
+and need to export their attributes to any module that calls them. To
+facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
+C<__CALLER__>, which may be specified as the qualifier of an attribute:
+
+ package Tie::Me::Kangaroo:Down::Sport;
+
+ use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
+
+This causes Attribute::Handlers to define the C<Roo> attribute in the package
+that imports the Tie::Me::Kangaroo:Down::Sport module.
+
+Note that it is important to quote the __CALLER__::Roo identifier because
+a bug in perl 5.8 will refuse to parse it and cause an unknown error.
+
+=head3 Passing the tied object to C<tie>
+
+Occasionally it is important to pass a reference to the object being tied
+to the TIESCALAR, TIEHASH, etc. that ties it.
+
+The C<autotie> mechanism supports this too. The following code:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+has the same effect as:
+
+ tie my $var, 'Tie::Selfish', @args;
+
+But when C<"autotieref"> is used instead of C<"autotie">:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+the effect is to pass the C<tie> call an extra reference to the variable
+being tied:
+
+ tie my $var, 'Tie::Selfish', \$var, @args;
+
+
+
+=head1 EXAMPLES
+
+If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
+module, then the following code:
+
+ package main;
+ use MyClass;
+
+ my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub fn :Ugly(sister) :Omni('po',tent()) {...}
+ my @arr :Good :Omni(s/cie/nt/);
+ my %hsh :Good(q/bye/) :Omni(q/bus/);
+
+
+would cause the following handlers to be invoked:
+
+ # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Bad', # attr name
+ 0 # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Omni', # attr name
+ '-vorous' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # sub fn :Ugly(sister) :Omni('po',tent()) {...}
+
+ MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Ugly', # attr name
+ 'sister' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Omni', # attr name
+ ['po','acle'] # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my @arr :Good :Omni(s/cie/nt/);
+
+ MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Omni', # attr name
+ "" # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my %hsh :Good(q/bye) :Omni(q/bus/);
+
+ MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Good', # attr name
+ 'q/bye' # raw attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Omni', # attr name
+ 'bus' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+Installing handlers into UNIVERSAL, makes them...err..universal.
+For example:
+
+ package Descriptions;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+Let's you write:
+
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+ # etc.
+
+=head1 UTILITY FUNCTIONS
+
+This module offers a single utility function, C<findsym()>.
+
+=over 4
+
+=item findsym
+
+ my $symbol = Attribute::Handlers::findsym($package, $referent);
+
+The function looks in the symbol table of C<$package> for the typeglob for
+C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
+HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
+undef. Note that C<findsym> memoizes the typeglobs it has previously
+successfully found, so subsequent calls with the same arguments should be
+must faster.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<Bad attribute type: ATTR(%s)>
+
+An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
+type of referent it was defined to handle wasn't one of the five permitted:
+C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
+
+=item C<Attribute handler %s doesn't handle %s attributes>
+
+A handler for attributes of the specified name I<was> defined, but not
+for the specified type of declaration. Typically encountered whe trying
+to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
+attribute handler to some other type of variable.
+
+=item C<Declaration of %s attribute in package %s may clash with future reserved word>
+
+A handler for an attributes with an all-lowercase name was declared. An
+attribute with an all-lowercase name might have a meaning to Perl
+itself some day, even though most don't yet. Use a mixed-case attribute
+name, instead.
+
+=item C<Can't have two ATTR specifiers on one subroutine>
+
+You just can't, okay?
+Instead, put all the specifications together with commas between them
+in a single C<ATTR(I<specification>)>.
+
+=item C<Can't autotie a %s>
+
+You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
+C<"HASH">. They're the only things (apart from typeglobs -- which are
+not declarable) that Perl can tie.
+
+=item C<Internal error: %s symbol went missing>
+
+Something is rotten in the state of the program. An attributed
+subroutine ceased to exist between the point it was declared and the point
+at which its attribute handler(s) would have been called.
+
+=item C<Won't be able to apply END handler>
+
+You have defined an END handler for an attribute that is being applied
+to a lexical variable. Since the variable may not be available during END
+this won't happen.
+
+=back
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
+Garcia-Suarez (rgarciasuarez@gmail.com).
+
+Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
+Contact him with technical difficulties with respect to the packaging of the
+CPAN module.
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (c) 2001-2009, 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.
diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm
new file mode 100644
index 00000000000..26996058941
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Concise.pm
@@ -0,0 +1,1836 @@
+package B::Concise;
+# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
+# This program is free software; you can redistribute and/or modify it
+# under the same terms as Perl itself.
+
+# Note: we need to keep track of how many use declarations/BEGIN
+# blocks this module uses, so we can avoid printing them when user
+# asks for the BEGIN blocks in her program. Update the comments and
+# the count in concise_specials if you add or delete one. The
+# -MO=Concise counts as use #1.
+
+use strict; # use #2
+use warnings; # uses #3 and #4, since warnings uses Carp
+
+use Exporter (); # use #5
+
+our $VERSION = "0.78";
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw( set_style set_style_standard add_callback
+ concise_subref concise_cv concise_main
+ add_style walk_output compile reset_sequence );
+our %EXPORT_TAGS =
+ ( io => [qw( walk_output compile reset_sequence )],
+ style => [qw( add_style set_style_standard )],
+ cb => [qw( add_callback )],
+ mech => [qw( concise_subref concise_cv concise_main )], );
+
+# use #6
+use B qw(class ppname main_start main_root main_cv cstring svref_2object
+ SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
+ CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
+
+my %style =
+ ("terse" =>
+ ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
+ . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
+ "(*( )*)goto #class (#addr)\n",
+ "#class pp_#name"],
+ "concise" =>
+ ["#hyphseq2 (*( (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)"
+ . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n"
+ , " (*( )*) goto #seq\n",
+ "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
+ "linenoise" =>
+ ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
+ "gt_#seq ",
+ "(?(#seq)?)#noise#arg(?([#targarg])?)"],
+ "debug" =>
+ ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
+ ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
+ . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
+ . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
+ . "(?(\top_sv\t\t#svaddr\n)?)",
+ " GOTO #addr\n",
+ "#addr"],
+ "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
+ $ENV{B_CONCISE_TREE_FORMAT}],
+ );
+
+# Renderings, ie how Concise prints, is controlled by these vars
+# primary:
+our $stylename; # selects current style from %style
+my $order = "basic"; # how optree is walked & printed: basic, exec, tree
+
+# rendering mechanics:
+# these 'formats' are the line-rendering templates
+# they're updated from %style when $stylename changes
+my ($format, $gotofmt, $treefmt);
+
+# lesser players:
+my $base = 36; # how <sequence#> is displayed
+my $big_endian = 1; # more <sequence#> display
+my $tree_style = 0; # tree-order details
+my $banner = 1; # print banner before optree is traversed
+my $do_main = 0; # force printing of main routine
+my $show_src; # show source code
+
+# another factor: can affect all styles!
+our @callbacks; # allow external management
+
+set_style_standard("concise");
+
+my $curcv;
+my $cop_seq_base;
+
+sub set_style {
+ ($format, $gotofmt, $treefmt) = @_;
+ #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+ die "style '$newstyle' already exists, choose a new name\n"
+ if exists $style{$newstyle};
+ die "expecting 3 style-format args\n" unless @args == 3;
+ $style{$newstyle} = [@args];
+ $stylename = $newstyle; # update rendering state
+}
+
+sub set_style_standard {
+ ($stylename) = @_; # update rendering state
+ die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
+ set_style(@{$style{$stylename}});
+}
+
+sub add_callback {
+ push @callbacks, @_;
+}
+
+# output handle, used with all Concise-output printing
+our $walkHandle; # public for your convenience
+BEGIN { $walkHandle = \*STDOUT }
+
+sub walk_output { # updates $walkHandle
+ my $handle = shift;
+ return $walkHandle unless $handle; # allow use as accessor
+
+ if (ref $handle eq 'SCALAR') {
+ require Config;
+ die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
+ unless $Config::Config{useperlio};
+ # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
+ open my $tmp, '>', $handle; # but cant re-set existing STDOUT
+ $walkHandle = $tmp; # so use my $tmp as intermediate var
+ return $walkHandle;
+ }
+ my $iotype = ref $handle;
+ die "expecting argument/object that can print\n"
+ unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
+ $walkHandle = $handle;
+}
+
+sub concise_subref {
+ my($order, $coderef, $name) = @_;
+ my $codeobj = svref_2object($coderef);
+
+ return concise_stashref(@_)
+ unless ref $codeobj eq 'B::CV';
+ concise_cv_obj($order, $codeobj, $name);
+}
+
+sub concise_stashref {
+ my($order, $h) = @_;
+ local *s;
+ foreach my $k (sort keys %$h) {
+ next unless defined $h->{$k};
+ *s = $h->{$k};
+ my $coderef = *s{CODE} or next;
+ reset_sequence();
+ print "FUNC: ", *s, "\n";
+ my $codeobj = svref_2object($coderef);
+ next unless ref $codeobj eq 'B::CV';
+ eval { concise_cv_obj($order, $codeobj, $k) };
+ warn "err $@ on $codeobj" if $@;
+ }
+}
+
+# This should have been called concise_subref, but it was exported
+# under this name in versions before 0.56
+*concise_cv = \&concise_subref;
+
+sub concise_cv_obj {
+ my ($order, $cv, $name) = @_;
+ # name is either a string, or a CODE ref (copy of $cv arg??)
+
+ $curcv = $cv;
+
+ if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
+ print $walkHandle "$name is a constant sub, optimized to a $1\n";
+ return;
+ }
+ if ($cv->XSUB) {
+ print $walkHandle "$name is XS code\n";
+ return;
+ }
+ if (class($cv->START) eq "NULL") {
+ no strict 'refs';
+ if (ref $name eq 'CODE') {
+ print $walkHandle "coderef $name has no START\n";
+ }
+ elsif (exists &$name) {
+ print $walkHandle "$name exists in stash, but has no START\n";
+ }
+ else {
+ print $walkHandle "$name not in symbol table\n";
+ }
+ return;
+ }
+ sequence($cv->START);
+ if ($order eq "exec") {
+ walk_exec($cv->START);
+ }
+ elsif ($order eq "basic") {
+ # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+ my $root = $cv->ROOT;
+ unless (ref $root eq 'B::NULL') {
+ walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
+ } else {
+ print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
+ }
+ } else {
+ print $walkHandle tree($cv->ROOT, 0);
+ }
+}
+
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print $walkHandle tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
+sub concise_specials {
+ my($name, $order, @cv_s) = @_;
+ my $i = 1;
+ if ($name eq "BEGIN") {
+ splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
+ } elsif ($name eq "CHECK") {
+ pop @cv_s; # skip the CHECK block that calls us
+ }
+ for my $cv (@cv_s) {
+ print $walkHandle "$name $i:\n";
+ $i++;
+ concise_cv_obj($order, $cv, $name);
+ }
+}
+
+my $start_sym = "\e(0"; # "\cN" sometimes also works
+my $end_sym = "\e(B"; # "\cO" respectively
+
+my @tree_decorations =
+ ([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
+ [" ", "-", "+", "+", "|", "`", "", 0],
+ [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
+ [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
+ );
+
+my @render_packs; # collect -stash=<packages>
+
+sub compileOpts {
+ # set rendering state from options and args
+ my (@options,@args);
+ if (@_) {
+ @options = grep(/^-/, @_);
+ @args = grep(!/^-/, @_);
+ }
+ for my $o (@options) {
+ # mode/order
+ if ($o eq "-basic") {
+ $order = "basic";
+ } elsif ($o eq "-exec") {
+ $order = "exec";
+ } elsif ($o eq "-tree") {
+ $order = "tree";
+ }
+ # tree-specific
+ elsif ($o eq "-compact") {
+ $tree_style |= 1;
+ } elsif ($o eq "-loose") {
+ $tree_style &= ~1;
+ } elsif ($o eq "-vt") {
+ $tree_style |= 2;
+ } elsif ($o eq "-ascii") {
+ $tree_style &= ~2;
+ }
+ # sequence numbering
+ elsif ($o =~ /^-base(\d+)$/) {
+ $base = $1;
+ } elsif ($o eq "-bigendian") {
+ $big_endian = 1;
+ } elsif ($o eq "-littleendian") {
+ $big_endian = 0;
+ }
+ # miscellaneous, presentation
+ elsif ($o eq "-nobanner") {
+ $banner = 0;
+ } elsif ($o eq "-banner") {
+ $banner = 1;
+ }
+ elsif ($o eq "-main") {
+ $do_main = 1;
+ } elsif ($o eq "-nomain") {
+ $do_main = 0;
+ } elsif ($o eq "-src") {
+ $show_src = 1;
+ }
+ elsif ($o =~ /^-stash=(.*)/) {
+ my $pkg = $1;
+ no strict 'refs';
+ if (! %{$pkg.'::'}) {
+ eval "require $pkg";
+ } else {
+ require Config;
+ if (!$Config::Config{usedl}
+ && keys %{$pkg.'::'} == 1
+ && $pkg->can('bootstrap')) {
+ # It is something that we're staticly linked to, but hasn't
+ # yet been used.
+ eval "require $pkg";
+ }
+ }
+ push @render_packs, $pkg;
+ }
+ # line-style options
+ elsif (exists $style{substr($o, 1)}) {
+ $stylename = substr($o, 1);
+ set_style_standard($stylename);
+ } else {
+ warn "Option $o unrecognized";
+ }
+ }
+ return (@args);
+}
+
+sub compile {
+ my (@args) = compileOpts(@_);
+ return sub {
+ my @newargs = compileOpts(@_); # accept new rendering options
+ warn "disregarding non-options: @newargs\n" if @newargs;
+
+ for my $objname (@args) {
+ next unless $objname; # skip null args to avoid noisy responses
+
+ if ($objname eq "BEGIN") {
+ concise_specials("BEGIN", $order,
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
+ } elsif ($objname eq "INIT") {
+ concise_specials("INIT", $order,
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
+ } elsif ($objname eq "CHECK") {
+ concise_specials("CHECK", $order,
+ B::check_av->isa("B::AV") ?
+ B::check_av->ARRAY : ());
+ } elsif ($objname eq "UNITCHECK") {
+ concise_specials("UNITCHECK", $order,
+ B::unitcheck_av->isa("B::AV") ?
+ B::unitcheck_av->ARRAY : ());
+ } elsif ($objname eq "END") {
+ concise_specials("END", $order,
+ B::end_av->isa("B::AV") ?
+ B::end_av->ARRAY : ());
+ }
+ else {
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n"
+ if $banner;
+ $objref = $objname;
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ unless (exists &$objname) {
+ print $walkHandle "err: unknown function ($objname)\n";
+ return;
+ }
+ $objref = \&$objname;
+ }
+ concise_subref($order, $objref, $objname);
+ }
+ }
+ for my $pkg (@render_packs) {
+ no strict 'refs';
+ concise_stashref($order, \%{$pkg.'::'});
+ }
+
+ if (!@args or $do_main or @render_packs) {
+ print $walkHandle "main program:\n" if $do_main;
+ concise_main($order);
+ }
+ return @args; # something
+ }
+}
+
+my %labels;
+my $lastnext; # remembers op-chain, used to insert gotos
+
+my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
+ 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
+ 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
+
+no warnings 'qw'; # "Possible attempt to put comments..."; use #7
+my @linenoise =
+ qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
+ ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
+ -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
+ > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
+ ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
+ uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
+ a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
+ v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
+ ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
+ ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
+ -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
+ co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
+ g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
+ e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
+ Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
+
+my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+sub op_flags { # common flags (see BASOP.op_flags in op.h)
+ my($x) = @_;
+ my(@v);
+ push @v, "v" if ($x & 3) == 1;
+ push @v, "s" if ($x & 3) == 2;
+ push @v, "l" if ($x & 3) == 3;
+ push @v, "K" if $x & 4;
+ push @v, "P" if $x & 8;
+ push @v, "R" if $x & 16;
+ push @v, "M" if $x & 32;
+ push @v, "S" if $x & 64;
+ push @v, "*" if $x & 128;
+ return join("", @v);
+}
+
+sub base_n {
+ my $x = shift;
+ return "-" . base_n(-$x) if $x < 0;
+ my $str = "";
+ do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
+ $str = reverse $str if $big_endian;
+ return $str;
+}
+
+my %sequence_num;
+my $seq_max = 1;
+
+sub reset_sequence {
+ # reset the sequence
+ %sequence_num = ();
+ $seq_max = 1;
+ $lastnext = 0;
+}
+
+sub seq {
+ my($op) = @_;
+ return "-" if not exists $sequence_num{$$op};
+ return base_n($sequence_num{$$op});
+}
+
+sub walk_topdown {
+ my($op, $sub, $level) = @_;
+ $sub->($op, $level);
+ if ($op->flags & OPf_KIDS) {
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walk_topdown($kid, $sub, $level + 1);
+ }
+ }
+ elsif (class($op) eq "PMOP") {
+ my $maybe_root = $op->pmreplroot;
+ if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
+ # It really is the root of the replacement, not something
+ # else stored here for lack of space elsewhere
+ walk_topdown($maybe_root, $sub, $level + 1);
+ }
+ }
+}
+
+sub walklines {
+ my($ar, $level) = @_;
+ for my $l (@$ar) {
+ if (ref($l) eq "ARRAY") {
+ walklines($l, $level + 1);
+ } else {
+ $l->concise($level);
+ }
+ }
+}
+
+sub walk_exec {
+ my($top, $level) = @_;
+ my %opsseen;
+ my @lines;
+ my @todo = ([$top, \@lines]);
+ while (@todo and my($op, $targ) = @{shift @todo}) {
+ for (; $$op; $op = $op->next) {
+ last if $opsseen{$$op}++;
+ push @$targ, $op;
+ my $name = $op->name;
+ if (class($op) eq "LOGOP") {
+ my $ar = [];
+ push @$targ, $ar;
+ push @todo, [$op->other, $ar];
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $ar = [];
+ push @$targ, $ar;
+ push @todo, [$op->pmreplstart, $ar];
+ } elsif ($name =~ /^enter(loop|iter)$/) {
+ if ($] > 5.009) {
+ $labels{${$op->nextop}} = "NEXT";
+ $labels{${$op->lastop}} = "LAST";
+ $labels{${$op->redoop}} = "REDO";
+ } else {
+ $labels{$op->nextop->seq} = "NEXT";
+ $labels{$op->lastop->seq} = "LAST";
+ $labels{$op->redoop->seq} = "REDO";
+ }
+ }
+ }
+ }
+ walklines(\@lines, 0);
+}
+
+# The structure of this routine is purposely modeled after op.c's peep()
+sub sequence {
+ my($op) = @_;
+ my $oldop = 0;
+ return if class($op) eq "NULL" or exists $sequence_num{$$op};
+ for (; $$op; $op = $op->next) {
+ last if exists $sequence_num{$$op};
+ my $name = $op->name;
+ if ($name =~ /^(null|scalar|lineseq|scope)$/) {
+ next if $oldop and $ {$op->next};
+ } else {
+ $sequence_num{$$op} = $seq_max++;
+ if (class($op) eq "LOGOP") {
+ my $other = $op->other;
+ $other = $other->next while $other->name eq "null";
+ sequence($other);
+ } elsif (class($op) eq "LOOP") {
+ my $redoop = $op->redoop;
+ $redoop = $redoop->next while $redoop->name eq "null";
+ sequence($redoop);
+ my $nextop = $op->nextop;
+ $nextop = $nextop->next while $nextop->name eq "null";
+ sequence($nextop);
+ my $lastop = $op->lastop;
+ $lastop = $lastop->next while $lastop->name eq "null";
+ sequence($lastop);
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $replstart = $op->pmreplstart;
+ $replstart = $replstart->next while $replstart->name eq "null";
+ sequence($replstart);
+ }
+ }
+ $oldop = $op;
+ }
+}
+
+sub fmt_line { # generate text-line for op.
+ my($hr, $op, $text, $level) = @_;
+
+ $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
+
+ return '' if $hr->{SKIP}; # suppress line if a callback said so
+ return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
+
+ # spec: (?(text1#varText2)?)
+ $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
+ $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+
+ # spec: (x(exec_text;basic_text)x)
+ $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
+
+ # spec: (*(text)*)
+ $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
+
+ # spec: (*(text1;text2)*)
+ $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
+
+ # convert #Var to tag=>val form: Var\t#var
+ $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
+
+ # spec: #varN
+ $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
+
+ $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
+ $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
+
+ $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
+
+ chomp $text;
+ return "$text\n" if $text ne "";
+ return $text; # suppress empty lines
+}
+
+our %priv; # used to display each opcode's BASEOP.op_private values
+
+$priv{$_}{128} = "LVINTRO"
+ for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
+ "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
+ "padav", "padhv", "enteriter");
+$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
+$priv{"aassign"}{64} = "COMMON";
+$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE";
+$priv{"sassign"}{32} = "STATE";
+$priv{"sassign"}{64} = "BKWARD";
+$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
+@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
+ "COMPL", "GROWS");
+$priv{"repeat"}{64} = "DOLIST";
+$priv{"leaveloop"}{64} = "CONT";
+@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
+ for (qw(rv2gv rv2sv padsv aelem helem));
+$priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
+@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
+@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
+$priv{"gv"}{32} = "EARLYCV";
+$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
+$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
+ "enteriter");
+$priv{$_}{16} = "TARGMY"
+ for (map(($_,"s$_"),"chop", "chomp"),
+ map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
+ "add", "subtract", "negate"), "pow", "concat", "stringify",
+ "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
+ "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
+ "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
+ "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
+ "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
+ "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
+ "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
+ "setpriority", "time", "sleep");
+$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
+@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
+$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
+$priv{"list"}{64} = "GUESSED";
+$priv{"delete"}{64} = "SLICE";
+$priv{"exists"}{64} = "SUB";
+@{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");
+$priv{"reverse"}{8} = "INPLACE";
+$priv{"threadsv"}{64} = "SVREFd";
+@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
+ for ("open", "backtick");
+$priv{"exit"}{128} = "VMS";
+$priv{$_}{2} = "FTACCESS"
+ for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
+$priv{"entereval"}{2} = "HAS_HH";
+if ($] >= 5.009) {
+ # Stacked filetests are post 5.8.x
+ $priv{$_}{4} = "FTSTACKED"
+ for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+ "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+ "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+ "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+ "ftbinary");
+ # Lexical $_ is post 5.8.x
+ $priv{$_}{2} = "GREPLEX"
+ for ("mapwhile", "mapstart", "grepwhile", "grepstart");
+}
+
+our %hints; # used to display each COP's op_hints values
+
+# strict refs, subs, vars
+@hints{2,512,1024} = ('$', '&', '*');
+# integers, locale, bytes, arybase
+@hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
+# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
+@hints{256,131072,262144,524288} = ('{','%','<','>');
+# overload new integer, float, binary, string, re
+@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
+# taint and eval
+@hints{1048576,2097152} = ('T', 'E');
+# filetest access, UTF-8
+@hints{4194304,8388608} = ('X', 'U');
+
+sub _flags {
+ my($hash, $x) = @_;
+ my @s;
+ for my $flag (sort {$b <=> $a} keys %$hash) {
+ if ($hash->{$flag} and $x & $flag and $x >= $flag) {
+ $x -= $flag;
+ push @s, $hash->{$flag};
+ }
+ }
+ push @s, $x if $x;
+ return join(",", @s);
+}
+
+sub private_flags {
+ my($name, $x) = @_;
+ _flags($priv{$name}, $x);
+}
+
+sub hints_flags {
+ my($x) = @_;
+ _flags(\%hints, $x);
+}
+
+sub concise_sv {
+ my($sv, $hr, $preferpv) = @_;
+ $hr->{svclass} = class($sv);
+ $hr->{svclass} = "UV"
+ if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
+ Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
+ $hr->{svaddr} = sprintf("%#x", $$sv);
+ if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
+ my $gv = $sv;
+ my $stash = $gv->STASH->NAME; if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ $hr->{svval} = "*$stash" . $gv->SAFENAME;
+ return "*$stash" . $gv->SAFENAME;
+ } else {
+ if ($] >= 5.011) {
+ while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
+ $hr->{svval} .= "\\";
+ $sv = $sv->RV;
+ }
+ } else {
+ while (class($sv) eq "RV") {
+ $hr->{svval} .= "\\";
+ $sv = $sv->RV;
+ }
+ }
+ if (class($sv) eq "SPECIAL") {
+ $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
+ } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ $hr->{svval} .= $sv->NV;
+ } elsif ($sv->FLAGS & SVf_IOK) {
+ $hr->{svval} .= $sv->int_value;
+ } elsif ($sv->FLAGS & SVf_POK) {
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
+ }
+
+ $hr->{svval} = 'undef' unless defined $hr->{svval};
+ my $out = $hr->{svclass};
+ return $out .= " $hr->{svval}" ;
+ }
+}
+
+my %srclines;
+
+sub fill_srclines {
+ my $fullnm = shift;
+ if ($fullnm eq '-e') {
+ $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
+ return;
+ }
+ open (my $fh, '<', $fullnm)
+ or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
+ and return;
+ my @l = <$fh>;
+ chomp @l;
+ unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
+ $srclines{$fullnm} = \@l;
+}
+
+sub concise_op {
+ my ($op, $level, $format) = @_;
+ my %h;
+ $h{exname} = $h{name} = $op->name;
+ $h{NAME} = uc $h{name};
+ $h{class} = class($op);
+ $h{extarg} = $h{targ} = $op->targ;
+ $h{extarg} = "" unless $h{extarg};
+ if ($h{name} eq "null" and $h{targ}) {
+ # targ holds the old type
+ $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
+ $h{extarg} = "";
+ } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
+ # targ potentially holds a reference count
+ if ($op->private & 64) {
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $h{targarglife} = $h{targarg} = "$h{targ} $refs";
+ }
+ } elsif ($h{targ}) {
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
+ if (defined $padname and class($padname) ne "SPECIAL") {
+ $h{targarg} = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
+ if ($] < 5.009) {
+ $h{targarglife} = "$h{targarg}:FAKE";
+ } else {
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $fake = '';
+ $fake .= 'a'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+ $fake .= 'm'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+ $fake .= ':' . $padname->PARENT_PAD_INDEX
+ if $curcv->CvFLAGS & CVf_ANON;
+ $h{targarglife} = "$h{targarg}:FAKE:$fake";
+ }
+ }
+ else {
+ my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
+ my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $h{targarglife} = "$h{targarg}:$intro,$finish";
+ }
+ } else {
+ $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ }
+ }
+ $h{arg} = "";
+ $h{svclass} = $h{svaddr} = $h{svval} = "";
+ if ($h{class} eq "PMOP") {
+ my $precomp = $op->precomp;
+ if (defined $precomp) {
+ $precomp = cstring($precomp); # Escape literal control sequences
+ $precomp = "/$precomp/";
+ } else {
+ $precomp = "";
+ }
+ my $pmreplroot = $op->pmreplroot;
+ my $pmreplstart;
+ if (ref($pmreplroot) eq "B::GV") {
+ # with C<@stash_array = split(/pat/, str);>,
+ # *stash_array is stored in /pat/'s pmreplroot.
+ $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
+ } elsif (!ref($pmreplroot) and $pmreplroot) {
+ # same as the last case, except the value is actually a
+ # pad offset for where the GV is kept (this happens under
+ # ithreads)
+ my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
+ $h{arg} = "($precomp => \@" . $gv->NAME . ")";
+ } elsif ($ {$op->pmreplstart}) {
+ undef $lastnext;
+ $pmreplstart = "replstart->" . seq($op->pmreplstart);
+ $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
+ } else {
+ $h{arg} = "($precomp)";
+ }
+ } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+ $h{arg} = '("' . $op->pv . '")';
+ $h{svval} = '"' . $op->pv . '"';
+ } elsif ($h{class} eq "COP") {
+ my $label = $op->label;
+ $h{coplabel} = $label;
+ $label = $label ? "$label: " : "";
+ my $loc = $op->file;
+ my $pathnm = $loc;
+ $loc =~ s[.*/][];
+ my $ln = $op->line;
+ $loc .= ":$ln";
+ my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
+ my $arybase = $op->arybase;
+ $arybase = $arybase ? ' $[=' . $arybase : "";
+ $h{arg} = "($label$stash $cseq $loc$arybase)";
+ if ($show_src) {
+ fill_srclines($pathnm) unless exists $srclines{$pathnm};
+ # Would love to retain Jim's use of // but this code needs to be
+ # portable to 5.8.x
+ my $line = $srclines{$pathnm}[$ln];
+ $line = "-src unavailable under -e" unless defined $line;
+ $h{src} = "$ln: $line";
+ }
+ } elsif ($h{class} eq "LOOP") {
+ $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
+ . " redo->" . seq($op->redoop) . ")";
+ } elsif ($h{class} eq "LOGOP") {
+ undef $lastnext;
+ $h{arg} = "(other->" . seq($op->other) . ")";
+ }
+ elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
+ unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
+ my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
+ my $preferpv = $h{name} eq "method_named";
+ if ($h{class} eq "PADOP" or !${$op->sv}) {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
+ $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
+ $h{targarglife} = $h{targarg} = "";
+ } else {
+ $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
+ }
+ }
+ }
+ $h{seq} = $h{hyphseq} = seq($op);
+ $h{seq} = "" if $h{seq} eq "-";
+ if ($] > 5.009) {
+ $h{opt} = $op->opt;
+ $h{label} = $labels{$$op};
+ } else {
+ $h{seqnum} = $op->seq;
+ $h{label} = $labels{$op->seq};
+ }
+ $h{next} = $op->next;
+ $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
+ $h{nextaddr} = sprintf("%#x", $ {$op->next});
+ $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
+ $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
+ $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
+
+ $h{classsym} = $opclass{$h{class}};
+ $h{flagval} = $op->flags;
+ $h{flags} = op_flags($op->flags);
+ $h{privval} = $op->private;
+ $h{private} = private_flags($h{name}, $op->private);
+ if ($op->can("hints")) {
+ $h{hintsval} = $op->hints;
+ $h{hints} = hints_flags($h{hintsval});
+ } else {
+ $h{hintsval} = $h{hints} = '';
+ }
+ $h{addr} = sprintf("%#x", $$op);
+ $h{typenum} = $op->type;
+ $h{noise} = $linenoise[$op->type];
+
+ return fmt_line(\%h, $op, $format, $level);
+}
+
+sub B::OP::concise {
+ my($op, $level) = @_;
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto' line
+ my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext),
+ "goto" => seq($lastnext), # simplify goto '-' removal
+ };
+ print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
+ }
+ $lastnext = $op->next;
+ print $walkHandle concise_op($op, $level, $format);
+}
+
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto'
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print # $walkHandle
+ fmt_line($h, $op, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print # $walkHandle
+ concise_op($op, $level, $style{"terse"}[0]);
+}
+
+sub tree {
+ my $op = shift;
+ my $level = shift;
+ my $style = $tree_decorations[$tree_style];
+ my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
+ my $name = concise_op($op, $level, $treefmt);
+ if (not $op->flags & OPf_KIDS) {
+ return $name . "\n";
+ }
+ my @lines;
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ push @lines, tree($kid, $level+1);
+ }
+ my $i;
+ for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
+ $lines[$i] = $space . $lines[$i];
+ }
+ if ($i > 0) {
+ $lines[$i] = $last . $lines[$i];
+ while ($i-- > 1) {
+ if (substr($lines[$i], 0, 1) eq " ") {
+ $lines[$i] = $nokid . $lines[$i];
+ } else {
+ $lines[$i] = $kid . $lines[$i];
+ }
+ }
+ $lines[$i] = $kids . $lines[$i];
+ } else {
+ $lines[0] = $single . $lines[0];
+ }
+ return("$name$lead" . shift @lines,
+ map(" " x (length($name)+$size) . $_, @lines));
+}
+
+# *** Warning: fragile kludge ahead ***
+# Because the B::* modules run in the same interpreter as the code
+# they're compiling, their presence tends to distort the view we have of
+# the code we're looking at. In particular, perl gives sequence numbers
+# to COPs. If the program we're looking at were run on its own, this
+# would start at 1. Because all of B::Concise and all the modules it
+# uses are compiled first, though, by the time we get to the user's
+# program the sequence number is already pretty high, which could be
+# distracting if you're trying to tell OPs apart. Therefore we'd like to
+# subtract an offset from all the sequence numbers we display, to
+# restore the simpler view of the world. The trick is to know what that
+# offset will be, when we're still compiling B::Concise! If we
+# hardcoded a value, it would have to change every time B::Concise or
+# other modules we use do. To help a little, what we do here is compile
+# a little code at the end of the module, and compute the base sequence
+# number for the user's program as being a small offset later, so all we
+# have to worry about are changes in the offset.
+
+# [For 5.8.x and earlier perl is generating sequence numbers for all ops,
+# and using them to reference labels]
+
+
+# When you say "perl -MO=Concise -e '$a'", the output should look like:
+
+# 4 <@> leave[t1] vKP/REFC ->(end)
+# 1 <0> enter ->2
+ #^ smallest OP sequence number should be 1
+# 2 <;> nextstate(main 1 -e:1) v ->3
+ # ^ smallest COP sequence number should be 1
+# - <1> ex-rv2sv vK/1 ->4
+# 3 <$> gvsv(*a) s ->4
+
+# If the second of the marked numbers there isn't 1, it means you need
+# to update the corresponding magic number in the next line.
+# Remember, this needs to stay the last things in the module.
+
+# Why is this different for MacOS? Does it matter?
+my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
+$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Concise - Walk Perl syntax tree, printing concise info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Concise[,OPTIONS] foo.pl
+
+ use B::Concise qw(set_style add_callback);
+
+=head1 DESCRIPTION
+
+This compiler backend prints the internal OPs of a Perl program's syntax
+tree in one of several space-efficient text formats suitable for debugging
+the inner workings of perl or other compiler backends. It can print OPs in
+the order they appear in the OP tree, in the order they will execute, or
+in a text approximation to their tree structure, and the format of the
+information displayed is customizable. Its function is similar to that of
+perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
+sophisticated and flexible.
+
+=head1 EXAMPLE
+
+Here's two outputs (or 'renderings'), using the -exec and -basic
+(i.e. default) formatting conventions on the same code snippet.
+
+ % perl -MO=Concise,-exec -e '$a = $b + 42'
+ 1 <0> enter
+ 2 <;> nextstate(main 1 -e:1) v
+ 3 <#> gvsv[*b] s
+ 4 <$> const[IV 42] s
+ * 5 <2> add[t3] sK/2
+ 6 <#> gvsv[*a] s
+ 7 <2> sassign vKS/2
+ 8 <@> leave[1 ref] vKP/REFC
+
+In this -exec rendering, each opcode is executed in the order shown.
+The add opcode, marked with '*', is discussed in more detail.
+
+The 1st column is the op's sequence number, starting at 1, and is
+displayed in base 36 by default. Here they're purely linear; the
+sequences are very helpful when looking at code with loops and
+branches.
+
+The symbol between angle brackets indicates the op's type, for
+example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
+used in threaded perls. (see L</"OP class abbreviations">).
+
+The opname, as in B<'add[t1]'>, may be followed by op-specific
+information in parentheses or brackets (ex B<'[t1]'>).
+
+The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
+abbreviations">).
+
+ % perl -MO=Concise -e '$a = $b + 42'
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 1 <0> enter ->2
+ 2 <;> nextstate(main 1 -e:1) v ->3
+ 7 <2> sassign vKS/2 ->8
+ * 5 <2> add[t1] sK/2 ->6
+ - <1> ex-rv2sv sK/1 ->4
+ 3 <$> gvsv(*b) s ->4
+ 4 <$> const(IV 42) s ->5
+ - <1> ex-rv2sv sKRM*/1 ->7
+ 6 <$> gvsv(*a) s ->7
+
+The default rendering is top-down, so they're not in execution order.
+This form reflects the way the stack is used to parse and evaluate
+expressions; the add operates on the two terms below it in the tree.
+
+Nullops appear as C<ex-opname>, where I<opname> is an op that has been
+optimized away by perl. They're displayed with a sequence-number of
+'-', because they are not executed (they don't appear in previous
+example), they're printed here because they reflect the parse.
+
+The arrow points to the sequence number of the next op; they're not
+displayed in -exec mode, for obvious reasons.
+
+Note that because this rendering was done on a non-threaded perl, the
+PADOPs in the previous examples are now SVOPs, and some (but not all)
+of the square brackets have been replaced by round ones. This is a
+subtle feature to provide some visual distinction between renderings
+on threaded and un-threaded perls.
+
+
+=head1 OPTIONS
+
+Arguments that don't start with a hyphen are taken to be the names of
+subroutines to render; if no such functions are specified, the main
+body of the program (outside any subroutines, and not including use'd
+or require'd files) is rendered. Passing C<BEGIN>, C<UNITCHECK>,
+C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
+special blocks to be printed. Arguments must follow options.
+
+Options affect how things are rendered (ie printed). They're presented
+here by their visual effect, 1st being strongest. They're grouped
+according to how they interrelate; within each group the options are
+mutually exclusive (unless otherwise stated).
+
+=head2 Options for Opcode Ordering
+
+These options control the 'vertical display' of opcodes. The display
+'order' is also called 'mode' elsewhere in this document.
+
+=over 4
+
+=item B<-basic>
+
+Print OPs in the order they appear in the OP tree (a preorder
+traversal, starting at the root). The indentation of each OP shows its
+level in the tree, and the '->' at the end of the line indicates the
+next opcode in execution order. This mode is the default, so the flag
+is included simply for completeness.
+
+=item B<-exec>
+
+Print OPs in the order they would normally execute (for the majority
+of constructs this is a postorder traversal of the tree, ending at the
+root). In most cases the OP that usually follows a given OP will
+appear directly below it; alternate paths are shown by indentation. In
+cases like loops when control jumps out of a linear path, a 'goto'
+line is generated.
+
+=item B<-tree>
+
+Print OPs in a text approximation of a tree, with the root of the tree
+at the left and 'left-to-right' order of children transformed into
+'top-to-bottom'. Because this mode grows both to the right and down,
+it isn't suitable for large programs (unless you have a very wide
+terminal).
+
+=back
+
+=head2 Options for Line-Style
+
+These options select the line-style (or just style) used to render
+each opcode, and dictates what info is actually printed into each line.
+
+=over 4
+
+=item B<-concise>
+
+Use the author's favorite set of formatting conventions. This is the
+default, of course.
+
+=item B<-terse>
+
+Use formatting conventions that emulate the output of B<B::Terse>. The
+basic mode is almost indistinguishable from the real B<B::Terse>, and the
+exec mode looks very similar, but is in a more logical order and lacks
+curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
+is only vaguely reminiscent of B<B::Terse>.
+
+=item B<-linenoise>
+
+Use formatting conventions in which the name of each OP, rather than being
+written out in full, is represented by a one- or two-character abbreviation.
+This is mainly a joke.
+
+=item B<-debug>
+
+Use formatting conventions reminiscent of B<B::Debug>; these aren't
+very concise at all.
+
+=item B<-env>
+
+Use formatting conventions read from the environment variables
+C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+
+=back
+
+=head2 Options for tree-specific formatting
+
+=over 4
+
+=item B<-compact>
+
+Use a tree format in which the minimum amount of space is used for the
+lines connecting nodes (one character in most cases). This squeezes out
+a few precious columns of screen real estate.
+
+=item B<-loose>
+
+Use a tree format that uses longer edges to separate OP nodes. This format
+tends to look better than the compact one, especially in ASCII, and is
+the default.
+
+=item B<-vt>
+
+Use tree connecting characters drawn from the VT100 line-drawing set.
+This looks better if your terminal supports it.
+
+=item B<-ascii>
+
+Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
+look as clean as the VT100 characters, but they'll work with almost any
+terminal (or the horizontal scrolling mode of less(1)) and are suitable
+for text documentation or email. This is the default.
+
+=back
+
+These are pairwise exclusive, i.e. compact or loose, vt or ascii.
+
+=head2 Options controlling sequence numbering
+
+=over 4
+
+=item B<-base>I<n>
+
+Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
+digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
+for 37 will be 'A', and so on until 62. Values greater than 62 are not
+currently supported. The default is 36.
+
+=item B<-bigendian>
+
+Print sequence numbers with the most significant digit first. This is the
+usual convention for Arabic numerals, and the default.
+
+=item B<-littleendian>
+
+Print seqence numbers with the least significant digit first. This is
+obviously mutually exclusive with bigendian.
+
+=back
+
+=head2 Other options
+
+=over 4
+
+=item B<-src>
+
+With this option, the rendering of each statement (starting with the
+nextstate OP) will be preceded by the 1st line of source code that
+generates it. For example:
+
+ 1 <0> enter
+ # 1: my $i;
+ 2 <;> nextstate(main 1 junk.pl:1) v:{
+ 3 <0> padsv[$i:1,10] vM/LVINTRO
+ # 3: for $i (0..9) {
+ 4 <;> nextstate(main 3 junk.pl:3) v:{
+ 5 <0> pushmark s
+ 6 <$> const[IV 0] s
+ 7 <$> const[IV 9] s
+ 8 <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS
+ k <0> iter s
+ l <|> and(other->9) vK/1
+ # 4: print "line ";
+ 9 <;> nextstate(main 2 junk.pl:4) v
+ a <0> pushmark s
+ b <$> const[PV "line "] s
+ c <@> print vK
+ # 5: print "$i\n";
+ ...
+
+=item B<-stash="somepackage">
+
+With this, "somepackage" will be required, then the stash is
+inspected, and each function is rendered.
+
+=back
+
+The following options are pairwise exclusive.
+
+=over 4
+
+=item B<-main>
+
+Include the main program in the output, even if subroutines were also
+specified. This rendering is normally suppressed when a subroutine
+name or reference is given.
+
+=item B<-nomain>
+
+This restores the default behavior after you've changed it with '-main'
+(it's not normally needed). If no subroutine name/ref is given, main is
+rendered, regardless of this flag.
+
+=item B<-nobanner>
+
+Renderings usually include a banner line identifying the function name
+or stringified subref. This suppresses the printing of the banner.
+
+TBC: Remove the stringified coderef; while it provides a 'cookie' for
+each function rendered, the cookies used should be 1,2,3.. not a
+random hex-address. It also complicates string comparison of two
+different trees.
+
+=item B<-banner>
+
+restores default banner behavior.
+
+=item B<-banneris> => subref
+
+TBC: a hookpoint (and an option to set it) for a user-supplied
+function to produce a banner appropriate for users needs. It's not
+ideal, because the rendering-state variables, which are a natural
+candidate for use in concise.t, are unavailable to the user.
+
+=back
+
+=head2 Option Stickiness
+
+If you invoke Concise more than once in a program, you should know that
+the options are 'sticky'. This means that the options you provide in
+the first call will be remembered for the 2nd call, unless you
+re-specify or change them.
+
+=head1 ABBREVIATIONS
+
+The concise style uses symbols to convey maximum info with minimal
+clutter (like hex addresses). With just a little practice, you can
+start to see the flowers, not just the branches, in the trees.
+
+=head2 OP class abbreviations
+
+These symbols appear before the op-name, and indicate the
+B:: namespace that represents the ops in your Perl code.
+
+ 0 OP (aka BASEOP) An OP with no children
+ 1 UNOP An OP with one child
+ 2 BINOP An OP with two children
+ | LOGOP A control branch OP
+ @ LISTOP An OP that could have lots of children
+ / PMOP An OP with a regular expression
+ $ SVOP An OP with an SV
+ " PVOP An OP with a string
+ { LOOP An OP that holds pointers for a loop
+ ; COP An OP that marks the start of a statement
+ # PADOP An OP with a GV on the pad
+
+=head2 OP flags abbreviations
+
+OP flags are either public or private. The public flags alter the
+behavior of each opcode in consistent ways, and are represented by 0
+or more single characters.
+
+ v OPf_WANT_VOID Want nothing (void context)
+ s OPf_WANT_SCALAR Want single value (scalar context)
+ l OPf_WANT_LIST Want list of any length (list context)
+ Want is unknown
+ K OPf_KIDS There is a firstborn child.
+ P OPf_PARENS This operator was parenthesized.
+ (Or block needs explicit scope entry.)
+ R OPf_REF Certified reference.
+ (Return container, not containee).
+ M OPf_MOD Will modify (lvalue).
+ S OPf_STACKED Some arg is arriving on the stack.
+ * OPf_SPECIAL Do something weird for this op (see op.h)
+
+Private flags, if any are set for an opcode, are displayed after a '/'
+
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 7 <2> sassign vKS/2 ->8
+
+They're opcode specific, and occur less often than the public ones, so
+they're represented by short mnemonics instead of single-chars; see
+F<op.h> for gory details, or try this quick 2-liner:
+
+ $> perl -MB::Concise -de 1
+ DB<1> |x \%B::Concise::priv
+
+=head1 FORMATTING SPECIFICATIONS
+
+For each line-style ('concise', 'terse', 'linenoise', etc.) there are
+3 format-specs which control how OPs are rendered.
+
+The first is the 'default' format, which is used in both basic and exec
+modes to print all opcodes. The 2nd, goto-format, is used in exec
+mode when branches are encountered. They're not real opcodes, and are
+inserted to look like a closing curly brace. The tree-format is tree
+specific.
+
+When a line is rendered, the correct format-spec is copied and scanned
+for the following items; data is substituted in, and other
+manipulations like basic indenting are done, for each opcode rendered.
+
+There are 3 kinds of items that may be populated; special patterns,
+#vars, and literal text, which is copied verbatim. (Yes, it's a set
+of s///g steps.)
+
+=head2 Special Patterns
+
+These items are the primitives used to perform indenting, and to
+select text from amongst alternatives.
+
+=over 4
+
+=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
+
+Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
+
+=item B<(*(>I<text>B<)*)>
+
+Generates one copy of I<text> for each indentation level.
+
+=item B<(*(>I<text1>B<;>I<text2>B<)*)>
+
+Generates one fewer copies of I<text1> than the indentation level, followed
+by one copy of I<text2> if the indentation level is more than 0.
+
+=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
+
+If the value of I<var> is true (not empty or zero), generates the
+value of I<var> surrounded by I<text1> and I<Text2>, otherwise
+nothing.
+
+=item B<~>
+
+Any number of tildes and surrounding whitespace will be collapsed to
+a single space.
+
+=back
+
+=head2 # Variables
+
+These #vars represent opcode properties that you may want as part of
+your rendering. The '#' is intended as a private sigil; a #var's
+value is interpolated into the style-line, much like "read $this".
+
+These vars take 3 forms:
+
+=over 4
+
+=item B<#>I<var>
+
+A property named 'var' is assumed to exist for the opcodes, and is
+interpolated into the rendering.
+
+=item B<#>I<var>I<N>
+
+Generates the value of I<var>, left justified to fill I<N> spaces.
+Note that this means while you can have properties 'foo' and 'foo2',
+you cannot render 'foo2', but you could with 'foo2a'. You would be
+wise not to rely on this behavior going forward ;-)
+
+=item B<#>I<Var>
+
+This ucfirst form of #var generates a tag-value form of itself for
+display; it converts '#Var' into a 'Var => #var' style, which is then
+handled as described above. (Imp-note: #Vars cannot be used for
+conditional-fills, because the => #var transform is done after the check
+for #Var's value).
+
+=back
+
+The following variables are 'defined' by B::Concise; when they are
+used in a style, their respective values are plugged into the
+rendering of each opcode.
+
+Only some of these are used by the standard styles, the others are
+provided for you to delve into optree mechanics, should you wish to
+add a new style (see L</add_style> below) that uses them. You can
+also add new ones using L</add_callback>.
+
+=over 4
+
+=item B<#addr>
+
+The address of the OP, in hexadecimal.
+
+=item B<#arg>
+
+The OP-specific information of the OP (such as the SV for an SVOP, the
+non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
+
+=item B<#class>
+
+The B-determined class of the OP, in all caps.
+
+=item B<#classsym>
+
+A single symbol abbreviating the class of the OP.
+
+=item B<#coplabel>
+
+The label of the statement or block the OP is the start of, if any.
+
+=item B<#exname>
+
+The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
+
+=item B<#extarg>
+
+The target of the OP, or nothing for a nulled OP.
+
+=item B<#firstaddr>
+
+The address of the OP's first child, in hexadecimal.
+
+=item B<#flags>
+
+The OP's flags, abbreviated as a series of symbols.
+
+=item B<#flagval>
+
+The numeric value of the OP's flags.
+
+=item B<#hints>
+
+The COP's hint flags, rendered with abbreviated names if possible. An empty
+string if this is not a COP. Here are the symbols used:
+
+ $ strict refs
+ & strict subs
+ * strict vars
+ i integers
+ l locale
+ b bytes
+ [ arybase
+ { block scope
+ % localise %^H
+ < open in
+ > open out
+ I overload int
+ F overload float
+ B overload binary
+ S overload string
+ R overload re
+ T taint
+ E eval
+ X filetest access
+ U utf-8
+
+=item B<#hintsval>
+
+The numeric value of the COP's hint flags, or an empty string if this is not
+a COP.
+
+=item B<#hyphseq>
+
+The sequence number of the OP, or a hyphen if it doesn't have one.
+
+=item B<#label>
+
+'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
+mode, or empty otherwise.
+
+=item B<#lastaddr>
+
+The address of the OP's last child, in hexadecimal.
+
+=item B<#name>
+
+The OP's name.
+
+=item B<#NAME>
+
+The OP's name, in all caps.
+
+=item B<#next>
+
+The sequence number of the OP's next OP.
+
+=item B<#nextaddr>
+
+The address of the OP's next OP, in hexadecimal.
+
+=item B<#noise>
+
+A one- or two-character abbreviation for the OP's name.
+
+=item B<#private>
+
+The OP's private flags, rendered with abbreviated names if possible.
+
+=item B<#privval>
+
+The numeric value of the OP's private flags.
+
+=item B<#seq>
+
+The sequence number of the OP. Note that this is a sequence number
+generated by B::Concise.
+
+=item B<#seqnum>
+
+5.8.x and earlier only. 5.9 and later do not provide this.
+
+The real sequence number of the OP, as a regular number and not adjusted
+to be relative to the start of the real program. (This will generally be
+a fairly large number because all of B<B::Concise> is compiled before
+your program is).
+
+=item B<#opt>
+
+Whether or not the op has been optimised by the peephole optimiser.
+
+Only available in 5.9 and later.
+
+=item B<#sibaddr>
+
+The address of the OP's next youngest sibling, in hexadecimal.
+
+=item B<#svaddr>
+
+The address of the OP's SV, if it has an SV, in hexadecimal.
+
+=item B<#svclass>
+
+The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
+
+=item B<#svval>
+
+The value of the OP's SV, if it has one, in a short human-readable format.
+
+=item B<#targ>
+
+The numeric value of the OP's targ.
+
+=item B<#targarg>
+
+The name of the variable the OP's targ refers to, if any, otherwise the
+letter t followed by the OP's targ in decimal.
+
+=item B<#targarglife>
+
+Same as B<#targarg>, but followed by the COP sequence numbers that delimit
+the variable's lifetime (or 'end' for a variable in an open scope) for a
+variable.
+
+=item B<#typenum>
+
+The numeric value of the OP's type, in decimal.
+
+=back
+
+=head1 One-Liner Command tips
+
+=over 4
+
+=item perl -MO=Concise,bar foo.pl
+
+Renders only bar() from foo.pl. To see main, drop the ',bar'. To see
+both, add ',-main'
+
+=item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
+
+Identifies md5 as an XS function. The export is needed so that BC can
+find it in main.
+
+=item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
+
+Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
+Although POSIX isn't entirely consistent across platforms, this is
+likely to be present in virtually all of them.
+
+=item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
+
+This renders a print statement, which includes a call to the function.
+It's identical to rendering a file with a use call and that single
+statement, except for the filename which appears in the nextstate ops.
+
+=item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
+
+This is B<very> similar to previous, only the first two ops differ. This
+subroutine rendering is more representative, insofar as a single main
+program will have many subs.
+
+=item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
+
+This renders all functions in the B::Concise package with the source
+lines. It eschews the O framework so that the stashref can be passed
+directly to B::Concise::compile(). See -stash option for a more
+convenient way to render a package.
+
+=back
+
+=head1 Using B::Concise outside of the O framework
+
+The common (and original) usage of B::Concise was for command-line
+renderings of simple code, as given in EXAMPLE. But you can also use
+B<B::Concise> from your code, and call compile() directly, and
+repeatedly. By doing so, you can avoid the compile-time only
+operation of O.pm, and even use the debugger to step through
+B::Concise::compile() itself.
+
+Once you're doing this, you may alter Concise output by adding new
+rendering styles, and by optionally adding callback routines which
+populate new variables, if such were referenced from those (just
+added) styles.
+
+=head2 Example: Altering Concise Renderings
+
+ use B::Concise qw(set_style add_callback);
+ add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
+ add_callback
+ ( sub {
+ my ($h, $op, $format, $level, $stylename) = @_;
+ $h->{variable} = some_func($op);
+ });
+ $walker = B::Concise::compile(@options,@subnames,@subrefs);
+ $walker->();
+
+=head2 set_style()
+
+B<set_style> accepts 3 arguments, and updates the three format-specs
+comprising a line-style (basic-exec, goto, tree). It has one minor
+drawback though; it doesn't register the style under a new name. This
+can become an issue if you render more than once and switch styles.
+Thus you may prefer to use add_style() and/or set_style_standard()
+instead.
+
+=head2 set_style_standard($name)
+
+This restores one of the standard line-styles: C<terse>, C<concise>,
+C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
+names previously defined with add_style().
+
+=head2 add_style ()
+
+This subroutine accepts a new style name and three style arguments as
+above, and creates, registers, and selects the newly named style. It is
+an error to re-add a style; call set_style_standard() to switch between
+several styles.
+
+=head2 add_callback ()
+
+If your newly minted styles refer to any new #variables, you'll need
+to define a callback subroutine that will populate (or modify) those
+variables. They are then available for use in the style you've
+chosen.
+
+The callbacks are called for each opcode visited by Concise, in the
+same order as they are added. Each subroutine is passed five
+parameters.
+
+ 1. A hashref, containing the variable names and values which are
+ populated into the report-line for the op
+ 2. the op, as a B<B::OP> object
+ 3. a reference to the format string
+ 4. the formatting (indent) level
+ 5. the selected stylename
+
+To define your own variables, simply add them to the hash, or change
+existing values if you need to. The level and format are passed in as
+references to scalars, but it is unlikely that they will need to be
+changed or even used.
+
+=head2 Running B::Concise::compile()
+
+B<compile> accepts options as described above in L</OPTIONS>, and
+arguments, which are either coderefs, or subroutine names.
+
+It constructs and returns a $treewalker coderef, which when invoked,
+traverses, or walks, and renders the optrees of the given arguments to
+STDOUT. You can reuse this, and can change the rendering style used
+each time; thereafter the coderef renders in the new style.
+
+B<walk_output> lets you change the print destination from STDOUT to
+another open filehandle, or into a string passed as a ref (unless
+you've built perl with -Uuseperlio).
+
+ my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
+ walk_output(\my $buf);
+ $walker->(); # 1 renders -terse
+ set_style_standard('concise'); # 2
+ $walker->(); # 2 renders -concise
+ $walker->(@new); # 3 renders whatever
+ print "3 different renderings: terse, concise, and @new: $buf\n";
+
+When $walker is called, it traverses the subroutines supplied when it
+was created, and renders them using the current style. You can change
+the style afterwards in several different ways:
+
+ 1. call C<compile>, altering style or mode/order
+ 2. call C<set_style_standard>
+ 3. call $walker, passing @new options
+
+Passing new options to the $walker is the easiest way to change
+amongst any pre-defined styles (the ones you add are automatically
+recognized as options), and is the only way to alter rendering order
+without calling compile again. Note however that rendering state is
+still shared amongst multiple $walker objects, so they must still be
+used in a coordinated manner.
+
+=head2 B::Concise::reset_sequence()
+
+This function (not exported) lets you reset the sequence numbers (note
+that they're numbered arbitrarily, their goal being to be human
+readable). Its purpose is mostly to support testing, i.e. to compare
+the concise output from two identical anonymous subroutines (but
+different instances). Without the reset, B::Concise, seeing that
+they're separate optrees, generates different sequence numbers in
+the output.
+
+=head2 Errors
+
+Errors in rendering (non-existent function-name, non-existent coderef)
+are written to the STDOUT, or wherever you've set it via
+walk_output().
+
+Errors using the various *style* calls, and bad args to walk_output(),
+result in die(). Use an eval if you wish to catch these errors and
+continue processing.
+
+=head1 AUTHOR
+
+Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm
new file mode 100644
index 00000000000..f44d59dd022
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Debug.pm
@@ -0,0 +1,424 @@
+package B::Debug;
+
+our $VERSION = '1.12';
+
+use strict;
+require 5.006;
+use B qw(peekop class walkoptree walkoptree_exec
+ main_start main_root cstring sv_undef);
+use Config;
+my (@optype, @specialsv_name);
+require B;
+if ($] < 5.009) {
+ require B::Asmdata;
+ B::Asmdata->import qw(@optype @specialsv_name);
+} else {
+ B->import qw(@optype @specialsv_name);
+}
+my $have_B_Flags;
+if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
+ eval { require B::Flags and $have_B_Flags++ };
+}
+my %done_gv;
+
+sub _printop {
+ my $op = shift;
+ my $addr = ${$op} ? $op->ppaddr : '';
+ $addr =~ s/^PL_ppaddr// if $addr;
+ return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+}
+
+sub B::OP::debug {
+ my ($op) = @_;
+ printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
+%s (0x%lx)
+ op_ppaddr %s
+ op_next %s
+ op_sibling %s
+ op_targ %d
+ op_type %d
+EOT
+ if ($] > 5.009) {
+ printf <<'EOT', $op->opt;
+ op_opt %d
+EOT
+ } else {
+ printf <<'EOT', $op->seq;
+ op_seq %d
+EOT
+ }
+ if ($have_B_Flags) {
+ printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
+ op_flags %d %s
+ op_private %d %s
+EOT
+ } else {
+ printf <<'EOT', $op->flags, $op->private;
+ op_flags %d
+ op_private %d
+EOT
+ }
+}
+
+sub B::UNOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_first\t%s\n", _printop($op->first);
+}
+
+sub B::BINOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_last \t%s\n", _printop($op->last);
+}
+
+sub B::LOOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
+ op_redoop %s
+ op_nextop %s
+ op_lastop %s
+EOT
+}
+
+sub B::LOGOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_other\t%s\n", _printop($op->other);
+}
+
+sub B::LISTOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+ my ($op) = @_;
+ $op->B::LISTOP::debug();
+ printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
+ printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+ printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
+ if ($Config{'useithreads'}) {
+ printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
+ printf "\top_pmoffset\t%d\n", $op->pmoffset;
+ } else {
+ printf "\top_pmstash\t%s\n", cstring($op->pmstash);
+ }
+ printf "\top_precomp\t%s\n", cstring($op->precomp);
+ printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
+ printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
+ printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
+ $op->pmreplroot->debug if $] < 5.008;
+}
+
+sub B::COP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+ cop_label "%s"
+ cop_stashpv "%s"
+ cop_file "%s"
+ cop_seq %d
+ cop_arybase %d
+ cop_line %d
+ cop_warnings 0x%x
+ cop_io %s
+EOT
+}
+
+sub B::SVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_sv\t\t0x%x\n", ${$op->sv};
+ $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_pv\t\t%s\n", cstring($op->pv);
+}
+
+sub B::PADOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_padix\t%ld\n", $op->padix;
+}
+
+sub B::NULL::debug {
+ my ($sv) = @_;
+ if ($$sv == ${sv_undef()}) {
+ print "&sv_undef\n";
+ } else {
+ printf "NULL (0x%x)\n", $$sv;
+ }
+}
+
+sub B::SV::debug {
+ my ($sv) = @_;
+ if (!$$sv) {
+ print class($sv), " = NULL\n";
+ return;
+ }
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+ REFCNT %d
+ FLAGS 0x%x
+EOT
+}
+
+sub B::RV::debug {
+ my ($rv) = @_;
+ B::SV::debug($rv);
+ printf <<'EOT', ${$rv->RV};
+ RV 0x%x
+EOT
+ $rv->RV->debug;
+}
+
+sub B::PV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ my $pv = $sv->PV();
+ printf <<'EOT', cstring($pv), length($pv);
+ xpv_pv %s
+ xpv_cur %d
+EOT
+}
+
+sub B::IV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+ my ($sv) = @_;
+ $sv->B::IV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+ my ($sv) = @_;
+ $sv->B::PV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+ my ($sv) = @_;
+ $sv->B::PVIV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+ printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txbm_useful\t%d\n", $sv->USEFUL;
+ printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ my ($stash) = $sv->STASH;
+ my ($start) = $sv->START;
+ my ($root) = $sv->ROOT;
+ my ($padlist) = $sv->PADLIST;
+ my ($file) = $sv->FILE;
+ my ($gv) = $sv->GV;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
+ STASH 0x%x
+ START 0x%x
+ ROOT 0x%x
+ GV 0x%x
+ FILE %s
+ DEPTH %d
+ PADLIST 0x%x
+ OUTSIDE 0x%x
+ OUTSIDE_SEQ %d
+EOT
+ $start->debug if $start;
+ $root->debug if $root;
+ $gv->debug if $gv;
+ $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+ my ($av) = @_;
+ $av->B::SV::debug;
+ # tied arrays may leave out FETCHSIZE
+ my (@array) = eval { $av->ARRAY; };
+ print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
+ my $fill = eval { scalar(@array) };
+ if ($Config{'useithreads'}) {
+ printf <<'EOT', $fill, $av->MAX, $av->OFF;
+ FILL %d
+ MAX %d
+ OFF %d
+EOT
+ } else {
+ printf <<'EOT', $fill, $av->MAX;
+ FILL %d
+ MAX %d
+EOT
+ }
+ printf <<'EOT', $av->AvFLAGS if $] < 5.009;
+ AvFLAGS %d
+EOT
+}
+
+sub B::GV::debug {
+ my ($gv) = @_;
+ if ($done_gv{$$gv}++) {
+ printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
+ return;
+ }
+ my ($sv) = $gv->SV;
+ my ($av) = $gv->AV;
+ my ($cv) = $gv->CV;
+ $gv->B::SV::debug;
+ printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
+ NAME %s
+ STASH %s (0x%x)
+ SV 0x%x
+ GvREFCNT %d
+ FORM 0x%x
+ AV 0x%x
+ HV 0x%x
+ EGV 0x%x
+ CV 0x%x
+ CVGEN %d
+ LINE %d
+ FILE %s
+ GvFLAGS 0x%x
+EOT
+ $sv->debug if $sv;
+ $av->debug if $av;
+ $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+ my $sv = shift;
+ print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+ my $order = shift;
+ B::clearsym();
+ if ($order && $order eq "exec") {
+ return sub { walkoptree_exec(main_start, "debug") }
+ } else {
+ return sub { walkoptree(main_root, "debug") }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Debug - Walk Perl syntax tree, printing debug info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Debug[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
+
+=head1 OPTIONS
+
+With option -exec, walks tree in execute order,
+otherwise in basic order.
+
+=head1 Changes
+
+ 1.12 2010-02-10 rurban
+ remove archlib installation cruft, and use the proper PM rule.
+ By Todd Rinaldo (toddr)
+
+ 1.11 2008-07-14 rurban
+ avoid B::Flags in CORE tests not to crash on old XS in @INC
+
+ 1.10 2008-06-28 rurban
+ require 5.006; Test::More not possible in 5.00505
+ our => my
+
+ 1.09 2008-06-18 rurban
+ minor META.yml syntax fix
+ 5.8.0 ending nextstate test failure: be more tolerant
+ PREREQ_PM Test::More
+
+ 1.08 2008-06-17 rurban
+ support 5.00558 - 5.6.2
+
+ 1.07 2008-06-16 rurban
+ debug.t: fix strawberry perl quoting issue
+
+ 1.06 2008-06-11 rurban
+ added B::Flags output
+ dual-life CPAN as B-Debug-1.06 and CORE
+ protect scalar(@array) if tied arrays leave out FETCHSIZE
+
+ 1.05_03 2008-04-16 rurban
+ ithread fixes in B::AV
+ B-C-1.04_??
+
+ B-C-1.04_09 2008-02-24 rurban
+ support 5.8 (import Asmdata)
+
+ 1.05_02 2008-02-21 rurban
+ added _printop
+ B-C-1.04_08 and CORE
+
+ 1.05_01 2008-02-05 rurban
+ 5.10 fix for op->seq
+ B-C-1.04_04
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Reini Urban C<rurban@cpan.org>
+
+=head1 LICENSE
+
+Copyright (c) 1996, 1997 Malcolm Beattie
+Copyright (c) 2008 Reini Urban
+
+ 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, you can get one from the Perl
+ distribution. You should also have received a copy of the GNU General
+ Public License, in the file named "Copying". If not, you can get one
+ from the Perl distribution or else write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
new file mode 100644
index 00000000000..b8e220e8e5c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -0,0 +1,4875 @@
+# B::Deparse.pm
+# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
+# All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# This is based on the module of the same name by Malcolm Beattie,
+# but essentially none of his code remains.
+
+package B::Deparse;
+use Carp;
+use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
+ OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
+ OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+ OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
+ OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
+ OPpREVERSE_INPLACE OPpCONST_NOVER
+ SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
+ CVf_METHOD CVf_LVALUE
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
+ ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
+ ($] < 5.011 ? 'CVf_LOCKED' : ());
+$VERSION = 0.97_01;
+use strict;
+use vars qw/$AUTOLOAD/;
+use warnings ();
+
+BEGIN {
+ # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
+ # be to fake up a dummy CVf_LOCKED that will never actually be true.
+ *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
+}
+
+# Changes between 0.50 and 0.51:
+# - fixed nulled leave with live enter in sort { }
+# - fixed reference constants (\"str")
+# - handle empty programs gracefully
+# - handle infinte loops (for (;;) {}, while (1) {})
+# - differentiate between `for my $x ...' and `my $x; for $x ...'
+# - various minor cleanups
+# - moved globals into an object
+# - added `-u', like B::C
+# - package declarations using cop_stash
+# - subs, formats and code sorted by cop_seq
+# Changes between 0.51 and 0.52:
+# - added pp_threadsv (special variables under USE_5005THREADS)
+# - added documentation
+# Changes between 0.52 and 0.53:
+# - many changes adding precedence contexts and associativity
+# - added `-p' and `-s' output style options
+# - various other minor fixes
+# Changes between 0.53 and 0.54:
+# - added support for new `for (1..100)' optimization,
+# thanks to Gisle Aas
+# Changes between 0.54 and 0.55:
+# - added support for new qr// construct
+# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56:
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+# Changes between 0.56 and 0.561:
+# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
+# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
+# Changes between 0.561 and 0.57:
+# - stylistic changes to symbolic constant stuff
+# - handled scope in s///e replacement code
+# - added unquote option for expanding "" into concats, etc.
+# - split method and proto parts of pp_entersub into separate functions
+# - various minor cleanups
+# Changes after 0.57:
+# - added parens in \&foo (patch by Albert Dvornik)
+# Changes between 0.57 and 0.58:
+# - fixed `0' statements that weren't being printed
+# - added methods for use from other programs
+# (based on patches from James Duncan and Hugo van der Sanden)
+# - added -si and -sT to control indenting (also based on a patch from Hugo)
+# - added -sv to print something else instead of '???'
+# - preliminary version of utf8 tr/// handling
+# Changes after 0.58:
+# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
+# - added support for Hugo's new OP_SETSTATE (like nextstate)
+# Changes between 0.58 and 0.59
+# - added support for Chip's OP_METHOD_NAMED
+# - added support for Ilya's OPpTARGET_MY optimization
+# - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
+# Changes between 0.60 and 0.61 (mostly by Robin Houston)
+# - many bug-fixes
+# - support for pragmas and 'use'
+# - support for the little-used $[ variable
+# - support for __DATA__ sections
+# - UTF8 support
+# - BEGIN, CHECK, INIT and END blocks
+# - scoping of subroutine declarations fixed
+# - compile-time output from the input program can be suppressed, so that the
+# output is just the deparsed code. (a change to O.pm in fact)
+# - our() declarations
+# - *all* the known bugs are now listed in the BUGS section
+# - comprehensive test mechanism (TEST -deparse)
+# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
+# - bug-fixes
+# - new switch -P
+# - support for command-line switches (-l, -0, etc.)
+# Changes between 0.63 and 0.64
+# - support for //, CHECK blocks, and assertions
+# - improved handling of foreach loops and lexicals
+# - option to use Data::Dumper for constants
+# - more bug fixes
+# - discovered lots more bugs not yet fixed
+#
+# ...
+#
+# Changes between 0.72 and 0.73
+# - support new switch constructs
+
+# Todo:
+# (See also BUGS section at the end of this file)
+#
+# - finish tr/// changes
+# - add option for even more parens (generalize \&foo change)
+# - left/right context
+# - copy comments (look at real text with $^P?)
+# - avoid semis in one-statement blocks
+# - associativity of &&=, ||=, ?:
+# - ',' => '=>' (auto-unquote?)
+# - break long lines ("\r" as discretionary break?)
+# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
+# - more style options: brace style, hex vs. octal, quotes, ...
+# - print big ints as hex/octal instead of decimal (heuristic?)
+# - handle `my $x if 0'?
+# - version using op_next instead of op_first/sibling?
+# - avoid string copies (pass arrays, one big join?)
+# - here-docs?
+
+# Current test.deparse failures
+# comp/hints 6 - location of BEGIN blocks wrt. block openings
+# run/switchI 1 - missing -I switches entirely
+# perl -Ifoo -e 'print @INC'
+# op/caller 2 - warning mask propagates backwards before warnings::register
+# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
+# op/getpid 2 - can't assign to shared my() declaration (threads only)
+# 'my $x : shared = 5'
+# op/override 7 - parens on overriden require change v-string interpretation
+# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
+# c.f. 'BEGIN { *f = sub {0} }; f 2'
+# op/pat 774 - losing Unicode-ness of Latin1-only strings
+# 'use charnames ":short"; $x="\N{latin:a with acute}"'
+# op/recurse 12 - missing parens on recursive call makes it look like method
+# 'sub f { f($x) }'
+# op/subst 90 - inconsistent handling of utf8 under "use utf8"
+# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
+# op/tiehandle compile - "use strict" deparsed in the wrong place
+# uni/tr_ several
+# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
+# ext/Data/Dumper/t/dumper compile
+# ext/DB_file/several
+# ext/Encode/several
+# ext/Ernno/Errno warnings
+# ext/IO/lib/IO/t/io_sel 23
+# ext/PerlIO/t/encoding compile
+# ext/POSIX/t/posix 6
+# ext/Socket/Socket 8
+# ext/Storable/t/croak compile
+# lib/Attribute/Handlers/t/multi compile
+# lib/bignum/ several
+# lib/charnames 35
+# lib/constant 32
+# lib/English 40
+# lib/ExtUtils/t/bytes 4
+# lib/File/DosGlob compile
+# lib/Filter/Simple/t/data 1
+# lib/Math/BigInt/t/constant 1
+# lib/Net/t/config Deparse-warning
+# lib/overload compile
+# lib/Switch/ several
+# lib/Symbol 4
+# lib/Test/Simple several
+# lib/Term/Complete
+# lib/Tie/File/t/29_downcopy 5
+# lib/vars 22
+
+# Object fields (were globals):
+#
+# avoid_local:
+# (local($a), local($b)) and local($a, $b) have the same internal
+# representation but the short form looks better. We notice we can
+# use a large-scale local when checking the list, but need to prevent
+# individual locals too. This hash holds the addresses of OPs that
+# have already had their local-ness accounted for. The same thing
+# is done with my().
+#
+# curcv:
+# CV for current sub (or main program) being deparsed
+#
+# curcvlex:
+# Cached hash of lexical variables for curcv: keys are names,
+# each value is an array of pairs, indicating the cop_seq of scopes
+# in which a var of that name is valid.
+#
+# curcop:
+# COP for statement being deparsed
+#
+# curstash:
+# name of the current package for deparsed code
+#
+# subs_todo:
+# array of [cop_seq, CV, is_format?] for subs and formats we still
+# want to deparse
+#
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
+# subs_done, forms_done:
+# keys are addresses of GVs for subs and formats we've already
+# deparsed (or at least put into subs_todo)
+#
+# subs_declared
+# keys are names of subs for which we've printed declarations.
+# That means we can omit parentheses from the arguments.
+#
+# subs_deparsed
+# Keeps track of fully qualified names of all deparsed subs.
+#
+# parens: -p
+# linenums: -l
+# unquote: -q
+# cuddle: ` ' or `\n', depending on -sC
+# indent_size: -si
+# use_tabs: -sT
+# ex_const: -sv
+
+# A little explanation of how precedence contexts and associativity
+# work:
+#
+# deparse() calls each per-op subroutine with an argument $cx (short
+# for context, but not the same as the cx* in the perl core), which is
+# a number describing the op's parents in terms of precedence, whether
+# they're inside an expression or at statement level, etc. (see
+# chart below). When ops with children call deparse on them, they pass
+# along their precedence. Fractional values are used to implement
+# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
+# parentheses hacks. The major disadvantage of this scheme is that
+# it doesn't know about right sides and left sides, so say if you
+# assign a listop to a variable, it can't tell it's allowed to leave
+# the parens off the listop.
+
+# Precedences:
+# 26 [TODO] inside interpolation context ("")
+# 25 left terms and list operators (leftward)
+# 24 left ->
+# 23 nonassoc ++ --
+# 22 right **
+# 21 right ! ~ \ and unary + and -
+# 20 left =~ !~
+# 19 left * / % x
+# 18 left + - .
+# 17 left << >>
+# 16 nonassoc named unary operators
+# 15 nonassoc < > <= >= lt gt le ge
+# 14 nonassoc == != <=> eq ne cmp
+# 13 left &
+# 12 left | ^
+# 11 left &&
+# 10 left ||
+# 9 nonassoc .. ...
+# 8 right ?:
+# 7 right = += -= *= etc.
+# 6 left , =>
+# 5 nonassoc list operators (rightward)
+# 4 right not
+# 3 left and
+# 2 left or xor
+# 1 statement modifiers
+# 0.5 statements, but still print scopes as do { ... }
+# 0 statement level
+
+# Nonprinting characters with special meaning:
+# \cS - steal parens (see maybe_parens_unop)
+# \n - newline and indent
+# \t - increase indent
+# \b - decrease indent (`outdent')
+# \f - flush left (no indent)
+# \cK - kill following semicolon, if any
+
+sub null {
+ my $op = shift;
+ return class($op) eq "NULL";
+}
+
+sub todo {
+ my $self = shift;
+ my($cv, $is_form) = @_;
+ return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
+ my $seq;
+ if ($cv->OUTSIDE_SEQ) {
+ $seq = $cv->OUTSIDE_SEQ;
+ } elsif (!null($cv->START) and is_state($cv->START)) {
+ $seq = $cv->START->cop_seq;
+ } else {
+ $seq = 0;
+ }
+ push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
+ unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
+ $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
+ }
+}
+
+sub next_todo {
+ my $self = shift;
+ my $ent = shift @{$self->{'subs_todo'}};
+ my $cv = $ent->[1];
+ my $gv = $cv->GV;
+ my $name = $self->gv_name($gv);
+ if ($ent->[2]) {
+ return "format $name =\n"
+ . $self->deparse_format($ent->[1]). "\n";
+ } else {
+ $self->{'subs_declared'}{$name} = 1;
+ if ($name eq "BEGIN") {
+ my $use_dec = $self->begin_is_use($cv);
+ if (defined ($use_dec) and $self->{'expand'} < 5) {
+ return () if 0 == length($use_dec);
+ return $use_dec;
+ }
+ }
+ my $l = '';
+ if ($self->{'linenums'}) {
+ my $line = $gv->LINE;
+ my $file = $gv->FILE;
+ $l = "\n\f#line $line \"$file\"\n";
+ }
+ my $p = '';
+ if (class($cv->STASH) ne "SPECIAL") {
+ my $stash = $cv->STASH->NAME;
+ if ($stash ne $self->{'curstash'}) {
+ $p = "package $stash;\n";
+ $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
+ $self->{'curstash'} = $stash;
+ }
+ $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
+ }
+ return "${p}${l}sub $name " . $self->deparse_sub($cv);
+ }
+}
+
+# Return a "use" declaration for this BEGIN block, if appropriate
+sub begin_is_use {
+ my ($self, $cv) = @_;
+ my $root = $cv->ROOT;
+ local @$self{qw'curcv curcvlex'} = ($cv);
+#require B::Debug;
+#B::walkoptree($cv->ROOT, "debug");
+ my $lineseq = $root->first;
+ return if $lineseq->name ne "lineseq";
+
+ my $req_op = $lineseq->first->sibling;
+ return if $req_op->name ne "require";
+
+ my $module;
+ if ($req_op->first->private & OPpCONST_BARE) {
+ # Actually it should always be a bareword
+ $module = $self->const_sv($req_op->first)->PV;
+ $module =~ s[/][::]g;
+ $module =~ s/.pm$//;
+ }
+ else {
+ $module = $self->const($self->const_sv($req_op->first), 6);
+ }
+
+ my $version;
+ my $version_op = $req_op->sibling;
+ return if class($version_op) eq "NULL";
+ if ($version_op->name eq "lineseq") {
+ # We have a version parameter; skip nextstate & pushmark
+ my $constop = $version_op->first->next->next;
+
+ return unless $self->const_sv($constop)->PV eq $module;
+ $constop = $constop->sibling;
+ $version = $self->const_sv($constop);
+ if (class($version) eq "IV") {
+ $version = $version->int_value;
+ } elsif (class($version) eq "NV") {
+ $version = $version->NV;
+ } elsif (class($version) ne "PVMG") {
+ # Includes PVIV and PVNV
+ $version = $version->PV;
+ } else {
+ # version specified as a v-string
+ $version = 'v'.join '.', map ord, split //, $version->PV;
+ }
+ $constop = $constop->sibling;
+ return if $constop->name ne "method_named";
+ return if $self->const_sv($constop)->PV ne "VERSION";
+ }
+
+ $lineseq = $version_op->sibling;
+ return if $lineseq->name ne "lineseq";
+ my $entersub = $lineseq->first->sibling;
+ if ($entersub->name eq "stub") {
+ return "use $module $version ();\n" if defined $version;
+ return "use $module ();\n";
+ }
+ return if $entersub->name ne "entersub";
+
+ # See if there are import arguments
+ my $args = '';
+
+ my $svop = $entersub->first->sibling; # Skip over pushmark
+ return unless $self->const_sv($svop)->PV eq $module;
+
+ # Pull out the arguments
+ for ($svop=$svop->sibling; $svop->name ne "method_named";
+ $svop = $svop->sibling) {
+ $args .= ", " if length($args);
+ $args .= $self->deparse($svop, 6);
+ }
+
+ my $use = 'use';
+ my $method_named = $svop;
+ return if $method_named->name ne "method_named";
+ my $method_name = $self->const_sv($method_named)->PV;
+
+ if ($method_name eq "unimport") {
+ $use = 'no';
+ }
+
+ # Certain pragmas are dealt with using hint bits,
+ # so we ignore them here
+ if ($module eq 'strict' || $module eq 'integer'
+ || $module eq 'bytes' || $module eq 'warnings'
+ || $module eq 'feature') {
+ return "";
+ }
+
+ if (defined $version && length $args) {
+ return "$use $module $version ($args);\n";
+ } elsif (defined $version) {
+ return "$use $module $version;\n";
+ } elsif (length $args) {
+ return "$use $module ($args);\n";
+ } else {
+ return "$use $module;\n";
+ }
+}
+
+sub stash_subs {
+ my ($self, $pack) = @_;
+ my (@ret, $stash);
+ if (!defined $pack) {
+ $pack = '';
+ $stash = \%::;
+ }
+ else {
+ $pack =~ s/(::)?$/::/;
+ no strict 'refs';
+ $stash = \%$pack;
+ }
+ my %stash = svref_2object($stash)->ARRAY;
+ while (my ($key, $val) = each %stash) {
+ my $class = class($val);
+ if ($class eq "PV") {
+ # Just a prototype. As an ugly but fairly effective way
+ # to find out if it belongs here is to see if the AUTOLOAD
+ # (if any) for the stash was defined in one of our files.
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+ } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
+ # Just a name. As above.
+ # But skip proxy constant subroutines, as some form of perl-space
+ # visible code must have created them, be it a use statement, or
+ # some direct symbol-table manipulation code that we will Deparse
+ my $A = $stash{"AUTOLOAD"};
+ if (defined ($A) && class($A) eq "GV" && defined($A->CV)
+ && class($A->CV) eq "CV") {
+ my $AF = $A->FILE;
+ next unless $AF eq $0 || exists $self->{'files'}{$AF};
+ }
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "GV") {
+ if (class(my $cv = $val->CV) ne "SPECIAL") {
+ next if $self->{'subs_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 0);
+ }
+ if (class(my $cv = $val->FORM) ne "SPECIAL") {
+ next if $self->{'forms_done'}{$$val}++;
+ next if $$val != ${$cv->GV}; # Ignore imposters
+ $self->todo($cv, 1);
+ }
+ if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
+ $self->stash_subs($pack . $key)
+ unless $pack eq '' && $key eq 'main::';
+ # avoid infinite recursion
+ }
+ }
+ }
+}
+
+sub print_protos {
+ my $self = shift;
+ my $ar;
+ my @ret;
+ foreach $ar (@{$self->{'protos_todo'}}) {
+ my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+ push @ret, "sub " . $ar->[0] . "$proto;\n";
+ }
+ delete $self->{'protos_todo'};
+ return @ret;
+}
+
+sub style_opts {
+ my $self = shift;
+ my $opts = shift;
+ my $opt;
+ while (length($opt = substr($opts, 0, 1))) {
+ if ($opt eq "C") {
+ $self->{'cuddle'} = " ";
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "i") {
+ $opts =~ s/^i(\d+)//;
+ $self->{'indent_size'} = $1;
+ } elsif ($opt eq "T") {
+ $self->{'use_tabs'} = 1;
+ $opts = substr($opts, 1);
+ } elsif ($opt eq "v") {
+ $opts =~ s/^v([^.]*)(.|$)//;
+ $self->{'ex_const'} = $1;
+ }
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->{'cuddle'} = "\n";
+ $self->{'curcop'} = undef;
+ $self->{'curstash'} = "main";
+ $self->{'ex_const'} = "'???'";
+ $self->{'expand'} = 0;
+ $self->{'files'} = {};
+ $self->{'indent_size'} = 4;
+ $self->{'linenums'} = 0;
+ $self->{'parens'} = 0;
+ $self->{'subs_todo'} = [];
+ $self->{'unquote'} = 0;
+ $self->{'use_dumper'} = 0;
+ $self->{'use_tabs'} = 0;
+
+ $self->{'ambient_arybase'} = 0;
+ $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
+ $self->{'ambient_hints'} = 0;
+ $self->{'ambient_hinthash'} = undef;
+ $self->init();
+
+ while (my $arg = shift @_) {
+ if ($arg eq "-d") {
+ $self->{'use_dumper'} = 1;
+ require Data::Dumper;
+ } elsif ($arg =~ /^-f(.*)/) {
+ $self->{'files'}{$1} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 1;
+ } elsif ($arg eq "-p") {
+ $self->{'parens'} = 1;
+ } elsif ($arg eq "-P") {
+ $self->{'noproto'} = 1;
+ } elsif ($arg eq "-q") {
+ $self->{'unquote'} = 1;
+ } elsif (substr($arg, 0, 2) eq "-s") {
+ $self->style_opts(substr $arg, 2);
+ } elsif ($arg =~ /^-x(\d)$/) {
+ $self->{'expand'} = $1;
+ }
+ }
+ return $self;
+}
+
+{
+ # Mask out the bits that L<warnings::register> uses
+ my $WARN_MASK;
+ BEGIN {
+ $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
+ }
+ sub WARN_MASK () {
+ return $WARN_MASK;
+ }
+}
+
+# Initialise the contextual information, either from
+# defaults provided with the ambient_pragmas method,
+# or from perl's own defaults otherwise.
+sub init {
+ my $self = shift;
+
+ $self->{'arybase'} = $self->{'ambient_arybase'};
+ $self->{'warnings'} = defined ($self->{'ambient_warnings'})
+ ? $self->{'ambient_warnings'} & WARN_MASK
+ : undef;
+ $self->{'hints'} = $self->{'ambient_hints'};
+ $self->{'hints'} &= 0xFF if $] < 5.009;
+ $self->{'hinthash'} = $self->{'ambient_hinthash'};
+
+ # also a convenient place to clear out subs_declared
+ delete $self->{'subs_declared'};
+}
+
+sub compile {
+ my(@args) = @_;
+ return sub {
+ my $self = B::Deparse->new(@args);
+ # First deparse command-line args
+ if (defined $^I) { # deparse -i
+ print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
+ }
+ if ($^W) { # deparse -w
+ print qq(BEGIN { \$^W = $^W; }\n);
+ }
+ if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
+ my $fs = perlstring($/) || 'undef';
+ my $bs = perlstring($O::savebackslash) || 'undef';
+ print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
+ }
+ my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+ my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+ my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+ my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
+ my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
+ for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
+ $self->todo($block, 0);
+ }
+ $self->stash_subs();
+ local($SIG{"__DIE__"}) =
+ sub {
+ if ($self->{'curcop'}) {
+ my $cop = $self->{'curcop'};
+ my($line, $file) = ($cop->line, $cop->file);
+ print STDERR "While deparsing $file near line $line,\n";
+ }
+ };
+ $self->{'curcv'} = main_cv;
+ $self->{'curcvlex'} = undef;
+ print $self->print_protos;
+ @{$self->{'subs_todo'}} =
+ sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
+ print $self->indent($self->deparse_root(main_root)), "\n"
+ unless null main_root;
+ my @text;
+ while (scalar(@{$self->{'subs_todo'}})) {
+ push @text, $self->next_todo;
+ }
+ print $self->indent(join("", @text)), "\n" if @text;
+
+ # Print __DATA__ section, if necessary
+ no strict 'refs';
+ my $laststash = defined $self->{'curcop'}
+ ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
+ if (defined *{$laststash."::DATA"}{IO}) {
+ print "package $laststash;\n"
+ unless $laststash eq $self->{'curstash'};
+ print "__DATA__\n";
+ print readline(*{$laststash."::DATA"});
+ }
+ }
+}
+
+sub coderef2text {
+ my $self = shift;
+ my $sub = shift;
+ croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
+
+ $self->init();
+ return $self->indent($self->deparse_sub(svref_2object($sub)));
+}
+
+sub ambient_pragmas {
+ my $self = shift;
+ my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
+
+ while (@_ > 1) {
+ my $name = shift();
+ my $val = shift();
+
+ if ($name eq 'strict') {
+ require strict;
+
+ if ($val eq 'none') {
+ $hint_bits &= ~strict::bits(qw/refs subs vars/);
+ next();
+ }
+
+ my @names;
+ if ($val eq "all") {
+ @names = qw/refs subs vars/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ', $val;
+ }
+ $hint_bits |= strict::bits(@names);
+ }
+
+ elsif ($name eq '$[') {
+ $arybase = $val;
+ }
+
+ elsif ($name eq 'integer'
+ || $name eq 'bytes'
+ || $name eq 'utf8') {
+ require "$name.pm";
+ if ($val) {
+ $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
+ }
+ else {
+ $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
+ }
+ }
+
+ elsif ($name eq 're') {
+ require re;
+ if ($val eq 'none') {
+ $hint_bits &= ~re::bits(qw/taint eval/);
+ next();
+ }
+
+ my @names;
+ if ($val eq 'all') {
+ @names = qw/taint eval/;
+ }
+ elsif (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split' ',$val;
+ }
+ $hint_bits |= re::bits(@names);
+ }
+
+ elsif ($name eq 'warnings') {
+ if ($val eq 'none') {
+ $warning_bits = $warnings::NONE;
+ next();
+ }
+
+ my @names;
+ if (ref $val) {
+ @names = @$val;
+ }
+ else {
+ @names = split/\s+/, $val;
+ }
+
+ $warning_bits = $warnings::NONE if !defined ($warning_bits);
+ $warning_bits |= warnings::bits(@names);
+ }
+
+ elsif ($name eq 'warning_bits') {
+ $warning_bits = $val;
+ }
+
+ elsif ($name eq 'hint_bits') {
+ $hint_bits = $val;
+ }
+
+ elsif ($name eq '%^H') {
+ $hinthash = $val;
+ }
+
+ else {
+ croak "Unknown pragma type: $name";
+ }
+ }
+ if (@_) {
+ croak "The ambient_pragmas method expects an even number of args";
+ }
+
+ $self->{'ambient_arybase'} = $arybase;
+ $self->{'ambient_warnings'} = $warning_bits;
+ $self->{'ambient_hints'} = $hint_bits;
+ $self->{'ambient_hinthash'} = $hinthash;
+}
+
+# This method is the inner loop, so try to keep it simple
+sub deparse {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ Carp::confess("Null op in deparse") if !defined($op)
+ || class($op) eq "NULL";
+ my $meth = "pp_" . $op->name;
+ return $self->$meth($op, $cx);
+}
+
+sub indent {
+ my $self = shift;
+ my $txt = shift;
+ my @lines = split(/\n/, $txt);
+ my $leader = "";
+ my $level = 0;
+ my $line;
+ for $line (@lines) {
+ my $cmd = substr($line, 0, 1);
+ if ($cmd eq "\t" or $cmd eq "\b") {
+ $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
+ if ($self->{'use_tabs'}) {
+ $leader = "\t" x ($level / 8) . " " x ($level % 8);
+ } else {
+ $leader = " " x $level;
+ }
+ $line = substr($line, 1);
+ }
+ if (substr($line, 0, 1) eq "\f") {
+ $line = substr($line, 1); # no indent
+ } else {
+ $line = $leader . $line;
+ }
+ $line =~ s/\cK;?//g;
+ }
+ return join("\n", @lines);
+}
+
+sub deparse_sub {
+ my $self = shift;
+ my $cv = shift;
+ my $proto = "";
+Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
+Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
+ local $self->{'curcop'} = $self->{'curcop'};
+ if ($cv->FLAGS & SVf_POK) {
+ $proto = "(". $cv->PV . ") ";
+ }
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+ $proto .= ": ";
+ $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
+ $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
+ $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+ }
+
+ local($self->{'curcv'}) = $cv;
+ local($self->{'curcvlex'});
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $body;
+ if (not null $cv->ROOT) {
+ my $lineseq = $cv->ROOT->first;
+ if ($lineseq->name eq "lineseq") {
+ my @ops;
+ for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+ push @ops, $o;
+ }
+ $body = $self->lineseq(undef, @ops).";";
+ my $scope_en = $self->find_scope_en($lineseq);
+ if (defined $scope_en) {
+ my $subs = join"", $self->seq_subs($scope_en);
+ $body .= ";\n$subs" if length($subs);
+ }
+ }
+ else {
+ $body = $self->deparse($cv->ROOT->first, 0);
+ }
+ }
+ else {
+ my $sv = $cv->const_sv;
+ if ($$sv) {
+ # uh-oh. inlinable sub... format it differently
+ return $proto . "{ " . $self->const($sv, 0) . " }\n";
+ } else { # XSUB? (or just a declaration)
+ return "$proto;\n";
+ }
+ }
+ return $proto ."{\n\t$body\n\b}" ."\n";
+}
+
+sub deparse_format {
+ my $self = shift;
+ my $form = shift;
+ my @text;
+ local($self->{'curcv'}) = $form;
+ local($self->{'curcvlex'});
+ local($self->{'in_format'}) = 1;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $op = $form->ROOT;
+ my $kid;
+ return "\f." if $op->first->name eq 'stub'
+ || $op->first->name eq 'nextstate';
+ $op = $op->first->first; # skip leavewrite, lineseq
+ while (not null $op) {
+ $op = $op->sibling; # skip nextstate
+ my @exprs;
+ $kid = $op->first->sibling; # skip pushmark
+ push @text, "\f".$self->const_sv($kid)->PV;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 0);
+ }
+ push @text, "\f".join(", ", @exprs)."\n" if @exprs;
+ $op = $op->sibling;
+ }
+ return join("", @text) . "\f.";
+}
+
+sub is_scope {
+ my $op = shift;
+ return $op->name eq "leave" || $op->name eq "scope"
+ || $op->name eq "lineseq"
+ || ($op->name eq "null" && class($op) eq "UNOP"
+ && (is_scope($op->first) || $op->first->name eq "enter"));
+}
+
+sub is_state {
+ my $name = $_[0]->name;
+ return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
+}
+
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (!null($op) and null($op->sibling)
+ and $op->name eq "null" and class($op) eq "UNOP"
+ and (($op->first->name =~ /^(and|or)$/
+ and $op->first->first->sibling->name eq "lineseq")
+ or ($op->first->name eq "lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->name eq "unstack")
+ ));
+}
+
+# Check if the op and its sibling are the initialization and the rest of a
+# for (..;..;..) { ... } loop
+sub is_for_loop {
+ my $op = shift;
+ # This OP might be almost anything, though it won't be a
+ # nextstate. (It's the initialization, so in the canonical case it
+ # will be an sassign.) The sibling is a lineseq whose first child
+ # is a nextstate and whose second is a leaveloop.
+ my $lseq = $op->sibling;
+ if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
+ && (my $sib = $lseq->first->sibling)) {
+ return (!null($sib) && $sib->name eq "leaveloop");
+ }
+ }
+ return 0;
+}
+
+sub is_scalar {
+ my $op = shift;
+ return ($op->name eq "rv2sv" or
+ $op->name eq "padsv" or
+ $op->name eq "gv" or # only in array/hash constructs
+ $op->flags & OPf_KIDS && !null($op->first)
+ && $op->first->name eq "gvsv");
+}
+
+sub maybe_parens {
+ my $self = shift;
+ my($text, $cx, $prec) = @_;
+ if ($prec < $cx # unary ops nest just fine
+ or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
+ or $self->{'parens'})
+ {
+ $text = "($text)";
+ # In a unop, let parent reuse our parens; see maybe_parens_unop
+ $text = "\cS" . $text if $cx == 16;
+ return $text;
+ } else {
+ return $text;
+ }
+}
+
+# same as above, but get around the `if it looks like a function' rule
+sub maybe_parens_unop {
+ my $self = shift;
+ my($name, $kid, $cx) = @_;
+ if ($cx > 16 or $self->{'parens'}) {
+ $kid = $self->deparse($kid, 1);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ return "$name($kid)";
+ } else {
+ $kid = $self->deparse($kid, 16);
+ if ($name eq "umask" && $kid =~ /^\d+$/) {
+ $kid = sprintf("%#o", $kid);
+ }
+ if (substr($kid, 0, 1) eq "\cS") {
+ # use kid's parens
+ return $name . substr($kid, 1);
+ } elsif (substr($kid, 0, 1) eq "(") {
+ # avoid looks-like-a-function trap with extra parens
+ # (`+' can lead to ambiguities)
+ return "$name(" . $kid . ")";
+ } else {
+ return "$name $kid";
+ }
+ }
+}
+
+sub maybe_parens_func {
+ my $self = shift;
+ my($func, $text, $cx, $prec) = @_;
+ if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
+ return "$func($text)";
+ } else {
+ return "$func $text";
+ }
+}
+
+sub maybe_local {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
+ if ($op->private & (OPpLVAL_INTRO|$our_intro)
+ and not $self->{'avoid_local'}{$$op}) {
+ my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
+ if( $our_local eq 'our' ) {
+ # XXX This assertion fails code with non-ASCII identifiers,
+ # like ./ext/Encode/t/jperl.t
+ die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ $text =~ s/(\w+::)+//;
+ }
+ if (want_scalar($op)) {
+ return "$our_local $text";
+ } else {
+ return $self->maybe_parens_func("$our_local", $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+sub maybe_targmy {
+ my $self = shift;
+ my($op, $cx, $func, @args) = @_;
+ if ($op->private & OPpTARGET_MY) {
+ my $var = $self->padname($op->targ);
+ my $val = $func->($self, $op, 7, @args);
+ return $self->maybe_parens("$var = $val", $cx, 7);
+ } else {
+ return $func->($self, $op, $cx, @args);
+ }
+}
+
+sub padname_sv {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
+}
+
+sub maybe_my {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ my $my = $op->private & OPpPAD_STATE ? "state" : "my";
+ if (want_scalar($op)) {
+ return "$my $text";
+ } else {
+ return $self->maybe_parens_func($my, $text, $cx, 16);
+ }
+ } else {
+ return $text;
+ }
+}
+
+# The following OPs don't have functions:
+
+# pp_padany -- does not exist after parsing
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ s/^.*::pp_//) {
+ warn "unexpected OP_".uc $AUTOLOAD;
+ return "XXX";
+ } else {
+ die "Undefined subroutine $AUTOLOAD called";
+ }
+}
+
+sub DESTROY {} # Do not AUTOLOAD
+
+# $root should be the op which represents the root of whatever
+# we're sequencing here. If it's undefined, then we don't append
+# any subroutine declarations to the deparsed ops, otherwise we
+# append appropriate declarations.
+sub lineseq {
+ my($self, $root, @ops) = @_;
+ my($expr, @exprs);
+
+ my $out_cop = $self->{'curcop'};
+ my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
+ my $limit_seq;
+ if (defined $root) {
+ $limit_seq = $out_seq;
+ my $nseq;
+ $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
+ $limit_seq = $nseq if !defined($limit_seq)
+ or defined($nseq) && $nseq < $limit_seq;
+ }
+ $limit_seq = $self->{'limit_seq'}
+ if defined($self->{'limit_seq'})
+ && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
+ local $self->{'limit_seq'} = $limit_seq;
+
+ $self->walk_lineseq($root, \@ops,
+ sub { push @exprs, $_[0]} );
+
+ my $body = join(";\n", grep {length} @exprs);
+ my $subs = "";
+ if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
+ $subs = join "\n", $self->seq_subs($limit_seq);
+ }
+ return join(";\n", grep {length} $body, $subs);
+}
+
+sub scopeop {
+ my($real_block, $self, $op, $cx) = @_;
+ my $kid;
+ my @kids;
+
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'} if $real_block;
+ if ($real_block) {
+ $kid = $op->first->sibling; # skip enter
+ if (is_miniwhile($kid)) {
+ my $top = $kid->first;
+ my $name = $top->name;
+ if ($name eq "and") {
+ $name = "while";
+ } elsif ($name eq "or") {
+ $name = "until";
+ } else { # no conditional -> while 1 or until 0
+ return $self->deparse($top->first, 1) . " while 1";
+ }
+ my $cond = $top->first;
+ my $body = $cond->sibling->first; # skip lineseq
+ $cond = $self->deparse($cond, 1);
+ $body = $self->deparse($body, 1);
+ return "$body $name $cond";
+ }
+ } else {
+ $kid = $op->first;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
+ return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
+ } else {
+ my $lineseq = $self->lineseq($op, @kids);
+ return (length ($lineseq) ? "$lineseq;" : "");
+ }
+}
+
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
+
+# This is a special case of scopeop and lineseq, for the case of the
+# main_root. The difference is that we print the output statements as
+# soon as we get them, for the sake of impatient users.
+sub deparse_root {
+ my $self = shift;
+ my($op) = @_;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my @kids;
+ return if null $op->first; # Can happen, e.g., for Bytecode without -k
+ for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
+ }
+ $self->walk_lineseq($op, \@kids,
+ sub { print $self->indent($_[0].';');
+ print "\n" unless $_[1] == $#kids;
+ });
+}
+
+sub walk_lineseq {
+ my ($self, $op, $kids, $callback) = @_;
+ my @kids = @$kids;
+ for (my $i = 0; $i < @kids; $i++) {
+ my $expr = "";
+ if (is_state $kids[$i]) {
+ $expr = $self->deparse($kids[$i++], 0);
+ if ($i > $#kids) {
+ $callback->($expr, $i);
+ last;
+ }
+ }
+ if (is_for_loop($kids[$i])) {
+ $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+ next;
+ }
+ $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr =~ s/;\n?\z//;
+ $callback->($expr, $i);
+ }
+}
+
+# The BEGIN {} is used here because otherwise this code isn't executed
+# when you run B::Deparse on itself.
+my %globalnames;
+BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
+ "ENV", "ARGV", "ARGVOUT", "_"); }
+
+sub gv_name {
+ my $self = shift;
+ my $gv = shift;
+Carp::confess() unless ref($gv) eq "B::GV";
+ my $stash = $gv->STASH->NAME;
+ my $name = $gv->SAFENAME;
+ if ($stash eq 'main' && $name =~ /^::/) {
+ $stash = '::';
+ }
+ elsif (($stash eq 'main' && $globalnames{$name})
+ or ($stash eq $self->{'curstash'} && !$globalnames{$name}
+ && ($stash eq 'main' || $name !~ /::/))
+ or $name =~ /^[^A-Za-z_:]/)
+ {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ if ($name =~ /^(\^..|{)/) {
+ $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
+ }
+ return $stash . $name;
+}
+
+# Return the name to use for a stash variable.
+# If a lexical with the same name is in scope, it may need to be
+# fully-qualified.
+sub stash_variable {
+ my ($self, $prefix, $name) = @_;
+
+ return "$prefix$name" if $name =~ /::/;
+
+ unless ($prefix eq '$' || $prefix eq '@' || #'
+ $prefix eq '%' || $prefix eq '$#') {
+ return "$prefix$name";
+ }
+
+ my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
+ return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
+ return "$prefix$name";
+}
+
+sub lex_in_scope {
+ my ($self, $name) = @_;
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+
+ return 0 if !defined($self->{'curcop'});
+ my $seq = $self->{'curcop'}->cop_seq;
+ return 0 if !exists $self->{'curcvlex'}{$name};
+ for my $a (@{$self->{'curcvlex'}{$name}}) {
+ my ($st, $en) = @$a;
+ return 1 if $seq > $st && $seq <= $en;
+ }
+ return 0;
+}
+
+sub populate_curcvlex {
+ my $self = shift;
+ for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
+ my $padlist = $cv->PADLIST;
+ # an undef CV still in lexical chain
+ next if class($padlist) eq "SPECIAL";
+ my @padlist = $padlist->ARRAY;
+ my @ns = $padlist[0]->ARRAY;
+
+ for (my $i=0; $i<@ns; ++$i) {
+ next if class($ns[$i]) eq "SPECIAL";
+ next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
+ if (class($ns[$i]) eq "PV") {
+ # Probably that pesky lexical @_
+ next;
+ }
+ my $name = $ns[$i]->PVX;
+ my ($seq_st, $seq_en) =
+ ($ns[$i]->FLAGS & SVf_FAKE)
+ ? (0, 999999)
+ : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
+
+ push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
+ }
+ }
+}
+
+sub find_scope_st { ((find_scope(@_))[0]); }
+sub find_scope_en { ((find_scope(@_))[1]); }
+
+# Recurses down the tree, looking for pad variable introductions and COPs
+sub find_scope {
+ my ($self, $op, $scope_st, $scope_en) = @_;
+ carp("Undefined op in find_scope") if !defined $op;
+ return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
+
+ my @queue = ($op);
+ while(my $op = shift @queue ) {
+ for (my $o=$op->first; $$o; $o=$o->sibling) {
+ if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
+ my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
+ my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
+ $scope_st = $s if !defined($scope_st) || $s < $scope_st;
+ $scope_en = $e if !defined($scope_en) || $e > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif (is_state($o)) {
+ my $c = $o->cop_seq;
+ $scope_st = $c if !defined($scope_st) || $c < $scope_st;
+ $scope_en = $c if !defined($scope_en) || $c > $scope_en;
+ return ($scope_st, $scope_en);
+ }
+ elsif ($o->flags & OPf_KIDS) {
+ unshift (@queue, $o);
+ }
+ }
+ }
+
+ return ($scope_st, $scope_en);
+}
+
+# Returns a list of subs which should be inserted before the COP
+sub cop_subs {
+ my ($self, $op, $out_seq) = @_;
+ my $seq = $op->cop_seq;
+ # If we have nephews, then our sequence number indicates
+ # the cop_seq of the end of some sort of scope.
+ if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+ and my $nseq = $self->find_scope_st($op->sibling) ) {
+ $seq = $nseq;
+ }
+ $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
+ return $self->seq_subs($seq);
+}
+
+sub seq_subs {
+ my ($self, $seq) = @_;
+ my @text;
+#push @text, "# ($seq)\n";
+
+ return "" if !defined $seq;
+ while (scalar(@{$self->{'subs_todo'}})
+ and $seq > $self->{'subs_todo'}[0][0]) {
+ push @text, $self->next_todo;
+ }
+ return @text;
+}
+
+# Notice how subs and formats are inserted between statements here;
+# also $[ assignments and pragmas.
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ $self->{'curcop'} = $op;
+ my @text;
+ push @text, $self->cop_subs($op);
+ my $stash = $op->stashpv;
+ if ($stash ne $self->{'curstash'}) {
+ push @text, "package $stash;\n";
+ $self->{'curstash'} = $stash;
+ }
+
+ if ($self->{'arybase'} != $op->arybase) {
+ push @text, '$[ = '. $op->arybase .";\n";
+ $self->{'arybase'} = $op->arybase;
+ }
+
+ my $warnings = $op->warnings;
+ my $warning_bits;
+ if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
+ $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
+ }
+ elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
+ $warning_bits = $warnings::NONE;
+ }
+ elsif ($warnings->isa("B::SPECIAL")) {
+ $warning_bits = undef;
+ }
+ else {
+ $warning_bits = $warnings->PV & WARN_MASK;
+ }
+
+ if (defined ($warning_bits) and
+ !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
+ push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+ $self->{'warnings'} = $warning_bits;
+ }
+
+ if ($self->{'hints'} != $op->hints) {
+ push @text, declare_hints($self->{'hints'}, $op->hints);
+ $self->{'hints'} = $op->hints;
+ }
+
+ # hack to check that the hint hash hasn't changed
+ if ($] > 5.009 &&
+ "@{[sort %{$self->{'hinthash'} || {}}]}"
+ ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
+ push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
+ $self->{'hinthash'} = $op->hints_hash->HASH;
+ }
+
+ # This should go after of any branches that add statements, to
+ # increase the chances that it refers to the same line it did in
+ # the original program.
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . $op->file, qq'"\n';
+ }
+
+ push @text, $op->label . ": " if $op->label;
+
+ return join("", @text);
+}
+
+sub declare_warnings {
+ my ($from, $to) = @_;
+ if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
+ return "use warnings;\n";
+ }
+ elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
+ return "no warnings;\n";
+ }
+ return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
+}
+
+sub declare_hints {
+ my ($from, $to) = @_;
+ my $use = $to & ~$from;
+ my $no = $from & ~$to;
+ my $decls = "";
+ for my $pragma (hint_pragmas($use)) {
+ $decls .= "use $pragma;\n";
+ }
+ for my $pragma (hint_pragmas($no)) {
+ $decls .= "no $pragma;\n";
+ }
+ return $decls;
+}
+
+# Internal implementation hints that the core sets automatically, so don't need
+# (or want) to be passed back to the user
+my %ignored_hints = (
+ 'open<' => 1,
+ 'open>' => 1,
+ ':' => 1,
+);
+
+sub declare_hinthash {
+ my ($from, $to, $indent) = @_;
+ my @decls;
+ for my $key (keys %$to) {
+ next if $ignored_hints{$key};
+ if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
+ push @decls, qq(\$^H{'$key'} = q($to->{$key}););
+ }
+ }
+ for my $key (keys %$from) {
+ next if $ignored_hints{$key};
+ if (!exists $to->{$key}) {
+ push @decls, qq(delete \$^H{'$key'};);
+ }
+ }
+ @decls or return '';
+ return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
+}
+
+sub hint_pragmas {
+ my ($bits) = @_;
+ my @pragmas;
+ push @pragmas, "integer" if $bits & 0x1;
+ push @pragmas, "strict 'refs'" if $bits & 0x2;
+ push @pragmas, "bytes" if $bits & 0x8;
+ return @pragmas;
+}
+
+sub pp_dbstate { pp_nextstate(@_) }
+sub pp_setstate { pp_nextstate(@_) }
+
+sub pp_unstack { return "" } # see also leaveloop
+
+sub baseop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ return $name;
+}
+
+sub pp_stub {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if ($cx >= 1) {
+ return "()";
+ }
+ else {
+ return "();";
+ }
+}
+sub pp_wantarray { baseop(@_, "wantarray") }
+sub pp_fork { baseop(@_, "fork") }
+sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
+sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
+sub pp_time { maybe_targmy(@_, \&baseop, "time") }
+sub pp_tms { baseop(@_, "times") }
+sub pp_ghostent { baseop(@_, "gethostent") }
+sub pp_gnetent { baseop(@_, "getnetent") }
+sub pp_gprotoent { baseop(@_, "getprotoent") }
+sub pp_gservent { baseop(@_, "getservent") }
+sub pp_ehostent { baseop(@_, "endhostent") }
+sub pp_enetent { baseop(@_, "endnetent") }
+sub pp_eprotoent { baseop(@_, "endprotoent") }
+sub pp_eservent { baseop(@_, "endservent") }
+sub pp_gpwent { baseop(@_, "getpwent") }
+sub pp_spwent { baseop(@_, "setpwent") }
+sub pp_epwent { baseop(@_, "endpwent") }
+sub pp_ggrent { baseop(@_, "getgrent") }
+sub pp_sgrent { baseop(@_, "setgrent") }
+sub pp_egrent { baseop(@_, "endgrent") }
+sub pp_getlogin { baseop(@_, "getlogin") }
+
+sub POSTFIX () { 1 }
+
+# I couldn't think of a good short name, but this is the category of
+# symbolic unary operators with interesting precedence
+
+sub pfixop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0);
+ my $kid = $op->first;
+ $kid = $self->deparse($kid, $prec);
+ return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
+ $cx, $prec);
+}
+
+sub pp_preinc { pfixop(@_, "++", 23) }
+sub pp_predec { pfixop(@_, "--", 23) }
+sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_i_preinc { pfixop(@_, "++", 23) }
+sub pp_i_predec { pfixop(@_, "--", 23) }
+sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
+
+sub pp_negate { maybe_targmy(@_, \&real_negate) }
+sub real_negate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name =~ /^(i_)?negate$/) {
+ # avoid --$x
+ $self->pfixop($op, $cx, "-", 21.5);
+ } else {
+ $self->pfixop($op, $cx, "-", 21);
+ }
+}
+sub pp_i_negate { pp_negate(@_) }
+
+sub pp_not {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($cx <= 4) {
+ $self->pfixop($op, $cx, "not ", 4);
+ } else {
+ $self->pfixop($op, $cx, "!", 21);
+ }
+}
+
+sub unop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ if (not $name) {
+ # this deals with 'boolkeys' right now
+ return $self->deparse($kid,$cx);
+ }
+ my $builtinname = $name;
+ $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
+ if (defined prototype($builtinname)
+ && prototype($builtinname) =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $kid = $kid->first;
+ }
+
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_defined { unop(@_, "defined") }
+sub pp_undef { unop(@_, "undef") }
+sub pp_study { unop(@_, "study") }
+sub pp_ref { unop(@_, "ref") }
+sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
+
+sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
+sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
+sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
+sub pp_srand { unop(@_, "srand") }
+sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
+sub pp_log { maybe_targmy(@_, \&unop, "log") }
+sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
+sub pp_int { maybe_targmy(@_, \&unop, "int") }
+sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
+sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
+sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
+
+sub pp_length { maybe_targmy(@_, \&unop, "length") }
+sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
+sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
+
+sub pp_each { unop(@_, "each") }
+sub pp_values { unop(@_, "values") }
+sub pp_keys { unop(@_, "keys") }
+sub pp_boolkeys {
+ # no name because its an optimisation op that has no keyword
+ unop(@_,"");
+}
+sub pp_aeach { unop(@_, "each") }
+sub pp_avalues { unop(@_, "values") }
+sub pp_akeys { unop(@_, "keys") }
+sub pp_pop { unop(@_, "pop") }
+sub pp_shift { unop(@_, "shift") }
+
+sub pp_caller { unop(@_, "caller") }
+sub pp_reset { unop(@_, "reset") }
+sub pp_exit { unop(@_, "exit") }
+sub pp_prototype { unop(@_, "prototype") }
+
+sub pp_close { unop(@_, "close") }
+sub pp_fileno { unop(@_, "fileno") }
+sub pp_umask { unop(@_, "umask") }
+sub pp_untie { unop(@_, "untie") }
+sub pp_tied { unop(@_, "tied") }
+sub pp_dbmclose { unop(@_, "dbmclose") }
+sub pp_getc { unop(@_, "getc") }
+sub pp_eof { unop(@_, "eof") }
+sub pp_tell { unop(@_, "tell") }
+sub pp_getsockname { unop(@_, "getsockname") }
+sub pp_getpeername { unop(@_, "getpeername") }
+
+sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
+sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
+sub pp_readlink { unop(@_, "readlink") }
+sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
+sub pp_readdir { unop(@_, "readdir") }
+sub pp_telldir { unop(@_, "telldir") }
+sub pp_rewinddir { unop(@_, "rewinddir") }
+sub pp_closedir { unop(@_, "closedir") }
+sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
+sub pp_localtime { unop(@_, "localtime") }
+sub pp_gmtime { unop(@_, "gmtime") }
+sub pp_alarm { unop(@_, "alarm") }
+sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
+
+sub pp_dofile { unop(@_, "do") }
+sub pp_entereval { unop(@_, "eval") }
+
+sub pp_ghbyname { unop(@_, "gethostbyname") }
+sub pp_gnbyname { unop(@_, "getnetbyname") }
+sub pp_gpbyname { unop(@_, "getprotobyname") }
+sub pp_shostent { unop(@_, "sethostent") }
+sub pp_snetent { unop(@_, "setnetent") }
+sub pp_sprotoent { unop(@_, "setprotoent") }
+sub pp_sservent { unop(@_, "setservent") }
+sub pp_gpwnam { unop(@_, "getpwnam") }
+sub pp_gpwuid { unop(@_, "getpwuid") }
+sub pp_ggrnam { unop(@_, "getgrnam") }
+sub pp_ggrgid { unop(@_, "getgrgid") }
+
+sub pp_lock { unop(@_, "lock") }
+
+sub pp_continue { unop(@_, "continue"); }
+sub pp_break {
+ my ($self, $op) = @_;
+ return "" if $op->flags & OPf_SPECIAL;
+ unop(@_, "break");
+}
+
+sub givwhen {
+ my $self = shift;
+ my($op, $cx, $givwhen) = @_;
+
+ my $enterop = $op->first;
+ my ($head, $block);
+ if ($enterop->flags & OPf_SPECIAL) {
+ $head = "default";
+ $block = $self->deparse($enterop->first, 0);
+ }
+ else {
+ my $cond = $enterop->first;
+ my $cond_str = $self->deparse($cond, 1);
+ $head = "$givwhen ($cond_str)";
+ $block = $self->deparse($cond->sibling, 0);
+ }
+
+ return "$head {\n".
+ "\t$block\n".
+ "\b}\cK";
+}
+
+sub pp_leavegiven { givwhen(@_, "given"); }
+sub pp_leavewhen { givwhen(@_, "when"); }
+
+sub pp_exists {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpEXISTS_SUB) {
+ # Checking for the existence of a subroutine
+ return $self->maybe_parens_func("exists",
+ $self->pp_rv2cv($op->first, 16), $cx, 16);
+ }
+ if ($op->flags & OPf_SPECIAL) {
+ # Array element, not hash element
+ return $self->maybe_parens_func("exists",
+ $self->pp_aelem($op->first, 16), $cx, 16);
+ }
+ return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ $cx, 16);
+}
+
+sub pp_delete {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpSLICE) {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aslice($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_hslice($op->first, 16),
+ $cx, 16);
+ } else {
+ if ($op->flags & OPf_SPECIAL) {
+ # Deleting from an array, not a hash
+ return $self->maybe_parens_func("delete",
+ $self->pp_aelem($op->first, 16),
+ $cx, 16);
+ }
+ return $self->maybe_parens_func("delete",
+ $self->pp_helem($op->first, 16),
+ $cx, 16);
+ }
+}
+
+sub pp_require {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
+ if (class($op) eq "UNOP" and $op->first->name eq "const"
+ and $op->first->private & OPpCONST_BARE)
+ {
+ my $name = $self->const_sv($op->first)->PV;
+ $name =~ s[/][::]g;
+ $name =~ s/\.pm//g;
+ return "$opname $name";
+ } else {
+ $self->unop($op, $cx, $op->first->private & OPpCONST_NOVER ? "no" : $opname);
+ }
+}
+
+sub pp_scalar {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if (not null $kid->sibling) {
+ # XXX Was a here-doc
+ return $self->dquote($op);
+ }
+ $self->unop(@_, "scalar");
+}
+
+
+sub padval {
+ my $self = shift;
+ my $targ = shift;
+ return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
+}
+
+sub anon_hash_or_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+
+ my($pre, $post) = @{{"anonlist" => ["[","]"],
+ "anonhash" => ["{","}"]}->{$op->name}};
+ my($expr, @exprs);
+ $op = $op->first->sibling; # skip pushmark
+ for (; !null($op); $op = $op->sibling) {
+ $expr = $self->deparse($op, 6);
+ push @exprs, $expr;
+ }
+ if ($pre eq "{" and $cx < 1) {
+ # Disambiguate that it's not a block
+ $pre = "+{";
+ }
+ return $pre . join(", ", @exprs) . $post;
+}
+
+sub pp_anonlist {
+ my $self = shift;
+ my ($op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->anon_hash_or_list($op, $cx);
+ }
+ warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
+ return 'XXX';
+}
+
+*pp_anonhash = \&pp_anonlist;
+
+sub pp_refgen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "null") {
+ $kid = $kid->first;
+ if (!null($kid->sibling) and
+ $kid->sibling->name eq "anoncode") {
+ return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
+ } elsif ($kid->name eq "pushmark") {
+ my $sib_name = $kid->sibling->name;
+ if ($sib_name =~ /^(pad|rv2)[ah]v$/
+ and not $kid->sibling->flags & OPf_REF)
+ {
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ return "\\(" . $self->pp_list($op->first) . ")";
+ } elsif ($sib_name eq 'entersub') {
+ my $text = $self->deparse($kid->sibling, 1);
+ # Always show parens for \(&func()), but only with -p otherwise
+ $text = "($text)" if $self->{'parens'}
+ or $kid->sibling->private & OPpENTERSUB_AMPER;
+ return "\\$text";
+ }
+ }
+ }
+ $self->pfixop($op, $cx, "\\", 20);
+}
+
+sub e_anoncode {
+ my ($self, $info) = @_;
+ my $text = $self->deparse_sub($info->{code});
+ return "sub " . $text;
+}
+
+sub pp_srefgen { pp_refgen(@_) }
+
+sub pp_readline {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
+ return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
+ return $self->unop($op, $cx, "readline");
+}
+
+sub pp_rcatline {
+ my $self = shift;
+ my($op) = @_;
+ return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
+}
+
+# Unary operators that can occur as pseudo-listops inside double quotes
+sub dq_unop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ # If there's more than one kid, the first is an ex-pushmark.
+ $kid = $kid->sibling if not null $kid->sibling;
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_ucfirst { dq_unop(@_, "ucfirst") }
+sub pp_lcfirst { dq_unop(@_, "lcfirst") }
+sub pp_uc { dq_unop(@_, "uc") }
+sub pp_lc { dq_unop(@_, "lc") }
+sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
+
+sub loopex {
+ my $self = shift;
+ my ($op, $cx, $name) = @_;
+ if (class($op) eq "PVOP") {
+ return "$name " . $op->pv;
+ } elsif (class($op) eq "OP") {
+ return $name;
+ } elsif (class($op) eq "UNOP") {
+ # Note -- loop exits are actually exempt from the
+ # looks-like-a-func rule, but a few extra parens won't hurt
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ }
+}
+
+sub pp_last { loopex(@_, "last") }
+sub pp_next { loopex(@_, "next") }
+sub pp_redo { loopex(@_, "redo") }
+sub pp_goto { loopex(@_, "goto") }
+sub pp_dump { loopex(@_, "dump") }
+
+sub ftst {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if (class($op) eq "UNOP") {
+ # Genuine `-X' filetests are exempt from the LLAFR, but not
+ # l?stat(); for the sake of clarity, give'em all parens
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ } elsif (class($op) =~ /^(SV|PAD)OP$/) {
+ return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
+ } else { # I don't think baseop filetests ever survive ck_ftst, but...
+ return $name;
+ }
+}
+
+sub pp_lstat { ftst(@_, "lstat") }
+sub pp_stat { ftst(@_, "stat") }
+sub pp_ftrread { ftst(@_, "-R") }
+sub pp_ftrwrite { ftst(@_, "-W") }
+sub pp_ftrexec { ftst(@_, "-X") }
+sub pp_fteread { ftst(@_, "-r") }
+sub pp_ftewrite { ftst(@_, "-w") }
+sub pp_fteexec { ftst(@_, "-x") }
+sub pp_ftis { ftst(@_, "-e") }
+sub pp_fteowned { ftst(@_, "-O") }
+sub pp_ftrowned { ftst(@_, "-o") }
+sub pp_ftzero { ftst(@_, "-z") }
+sub pp_ftsize { ftst(@_, "-s") }
+sub pp_ftmtime { ftst(@_, "-M") }
+sub pp_ftatime { ftst(@_, "-A") }
+sub pp_ftctime { ftst(@_, "-C") }
+sub pp_ftsock { ftst(@_, "-S") }
+sub pp_ftchr { ftst(@_, "-c") }
+sub pp_ftblk { ftst(@_, "-b") }
+sub pp_ftfile { ftst(@_, "-f") }
+sub pp_ftdir { ftst(@_, "-d") }
+sub pp_ftpipe { ftst(@_, "-p") }
+sub pp_ftlink { ftst(@_, "-l") }
+sub pp_ftsuid { ftst(@_, "-u") }
+sub pp_ftsgid { ftst(@_, "-g") }
+sub pp_ftsvtx { ftst(@_, "-k") }
+sub pp_fttty { ftst(@_, "-t") }
+sub pp_fttext { ftst(@_, "-T") }
+sub pp_ftbinary { ftst(@_, "-B") }
+
+sub SWAP_CHILDREN () { 1 }
+sub ASSIGN () { 2 } # has OP= variant
+sub LIST_CONTEXT () { 4 } # Assignment is in list context
+
+my(%left, %right);
+
+sub assoc_class {
+ my $op = shift;
+ my $name = $op->name;
+ if ($name eq "concat" and $op->first->name eq "concat") {
+ # avoid spurious `=' -- see comment in pp_concat
+ return "concat";
+ }
+ if ($name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|x?or)$/
+ and null $op->first->sibling)
+ {
+ # Like all conditional constructs, OP_ANDs and OP_ORs are topped
+ # with a null that's used as the common end point of the two
+ # flows of control. For precedence purposes, ignore it.
+ # (COND_EXPRs have these too, but we don't bother with
+ # their associativity).
+ return assoc_class($op->first);
+ }
+ return $name . ($op->flags & OPf_STACKED ? "=" : "");
+}
+
+# Left associative operators, like `+', for which
+# $a + $b + $c is equivalent to ($a + $b) + $c
+
+BEGIN {
+ %left = ('multiply' => 19, 'i_multiply' => 19,
+ 'divide' => 19, 'i_divide' => 19,
+ 'modulo' => 19, 'i_modulo' => 19,
+ 'repeat' => 19,
+ 'add' => 18, 'i_add' => 18,
+ 'subtract' => 18, 'i_subtract' => 18,
+ 'concat' => 18,
+ 'left_shift' => 17, 'right_shift' => 17,
+ 'bit_and' => 13,
+ 'bit_or' => 12, 'bit_xor' => 12,
+ 'and' => 3,
+ 'or' => 2, 'xor' => 2,
+ );
+}
+
+sub deparse_binop_left {
+ my $self = shift;
+ my($op, $left, $prec) = @_;
+ if ($left{assoc_class($op)} && $left{assoc_class($left)}
+ and $left{assoc_class($op)} == $left{assoc_class($left)})
+ {
+ return $self->deparse($left, $prec - .00001);
+ } else {
+ return $self->deparse($left, $prec);
+ }
+}
+
+# Right associative operators, like `=', for which
+# $a = $b = $c is equivalent to $a = ($b = $c)
+
+BEGIN {
+ %right = ('pow' => 22,
+ 'sassign=' => 7, 'aassign=' => 7,
+ 'multiply=' => 7, 'i_multiply=' => 7,
+ 'divide=' => 7, 'i_divide=' => 7,
+ 'modulo=' => 7, 'i_modulo=' => 7,
+ 'repeat=' => 7,
+ 'add=' => 7, 'i_add=' => 7,
+ 'subtract=' => 7, 'i_subtract=' => 7,
+ 'concat=' => 7,
+ 'left_shift=' => 7, 'right_shift=' => 7,
+ 'bit_and=' => 7,
+ 'bit_or=' => 7, 'bit_xor=' => 7,
+ 'andassign' => 7,
+ 'orassign' => 7,
+ );
+}
+
+sub deparse_binop_right {
+ my $self = shift;
+ my($op, $right, $prec) = @_;
+ if ($right{assoc_class($op)} && $right{assoc_class($right)}
+ and $right{assoc_class($op)} == $right{assoc_class($right)})
+ {
+ return $self->deparse($right, $prec - .00001);
+ } else {
+ return $self->deparse($right, $prec);
+ }
+}
+
+sub binop {
+ my $self = shift;
+ my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if ($flags & SWAP_CHILDREN) {
+ ($left, $right) = ($right, $left);
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $left = "($left)" if $flags & LIST_CONTEXT
+ && $left !~ /^(my|our|local|)[\@\(]/;
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
+}
+
+sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
+sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
+sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
+
+sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
+sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
+sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
+sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
+sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
+
+sub pp_eq { binop(@_, "==", 14) }
+sub pp_ne { binop(@_, "!=", 14) }
+sub pp_lt { binop(@_, "<", 15) }
+sub pp_gt { binop(@_, ">", 15) }
+sub pp_ge { binop(@_, ">=", 15) }
+sub pp_le { binop(@_, "<=", 15) }
+sub pp_ncmp { binop(@_, "<=>", 14) }
+sub pp_i_eq { binop(@_, "==", 14) }
+sub pp_i_ne { binop(@_, "!=", 14) }
+sub pp_i_lt { binop(@_, "<", 15) }
+sub pp_i_gt { binop(@_, ">", 15) }
+sub pp_i_ge { binop(@_, ">=", 15) }
+sub pp_i_le { binop(@_, "<=", 15) }
+sub pp_i_ncmp { binop(@_, "<=>", 14) }
+
+sub pp_seq { binop(@_, "eq", 14) }
+sub pp_sne { binop(@_, "ne", 14) }
+sub pp_slt { binop(@_, "lt", 15) }
+sub pp_sgt { binop(@_, "gt", 15) }
+sub pp_sge { binop(@_, "ge", 15) }
+sub pp_sle { binop(@_, "le", 15) }
+sub pp_scmp { binop(@_, "cmp", 14) }
+
+sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
+sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
+
+sub pp_smartmatch {
+ my ($self, $op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->deparse($op->last, $cx);
+ }
+ else {
+ binop(@_, "~~", 14);
+ }
+}
+
+# `.' is special because concats-of-concats are optimized to save copying
+# by making all but the first concat stacked. The effect is as if the
+# programmer had written `($a . $b) .= $c', except legal.
+sub pp_concat { maybe_targmy(@_, \&real_concat) }
+sub real_concat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 18;
+ if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
+ $eq = "=";
+ $prec = 7;
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left .$eq $right", $cx, $prec);
+}
+
+# `x' is weird when the left arg is a list
+sub pp_repeat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 19;
+ if ($op->flags & OPf_STACKED) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if (null($right)) { # list repeat; count is inside left-side ex-list
+ my $kid = $left->first->sibling; # skip pushmark
+ my @exprs;
+ for (; !null($kid->sibling); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ $right = $kid;
+ $left = "(" . join(", ", @exprs). ")";
+ } else {
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ }
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left x$eq $right", $cx, $prec);
+}
+
+sub range {
+ my $self = shift;
+ my ($op, $cx, $type) = @_;
+ my $left = $op->first;
+ my $right = $left->sibling;
+ $left = $self->deparse($left, 9);
+ $right = $self->deparse($right, 9);
+ return $self->maybe_parens("$left $type $right", $cx, 9);
+}
+
+sub pp_flop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $flip = $op->first;
+ my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
+ return $self->range($flip->first, $cx, $type);
+}
+
+# one-line while/until is handled in pp_leave
+
+sub logop {
+ my $self = shift;
+ my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling;
+ if ($cx < 1 and is_scope($right) and $blockname
+ and $self->{'expand'} < 7)
+ { # if ($a) {$b}
+ $left = $self->deparse($left, 1);
+ $right = $self->deparse($right, 0);
+ return "$blockname ($left) {\n\t$right\n\b}\cK";
+ } elsif ($cx < 1 and $blockname and not $self->{'parens'}
+ and $self->{'expand'} < 7) { # $b if $a
+ $right = $self->deparse($right, 1);
+ $left = $self->deparse($left, 1);
+ return "$right $blockname $left";
+ } elsif ($cx > $lowprec and $highop) { # $a && $b
+ $left = $self->deparse_binop_left($op, $left, $highprec);
+ $right = $self->deparse_binop_right($op, $right, $highprec);
+ return $self->maybe_parens("$left $highop $right", $cx, $highprec);
+ } else { # $a and $b
+ $left = $self->deparse_binop_left($op, $left, $lowprec);
+ $right = $self->deparse_binop_right($op, $right, $lowprec);
+ return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
+ }
+}
+
+sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
+sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
+sub pp_dor { logop(@_, "//", 10) }
+
+# xor is syntactically a logop, but it's really a binop (contrary to
+# old versions of opcode.pl). Syntax is what matters here.
+sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
+
+sub logassignop {
+ my $self = shift;
+ my ($op, $cx, $opname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling->first; # skip sassign
+ $left = $self->deparse($left, 7);
+ $right = $self->deparse($right, 7);
+ return $self->maybe_parens("$left $opname $right", $cx, 7);
+}
+
+sub pp_andassign { logassignop(@_, "&&=") }
+sub pp_orassign { logassignop(@_, "||=") }
+sub pp_dorassign { logassignop(@_, "//=") }
+
+sub listop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ return $name if null $kid;
+ my $first;
+ $name = "socketpair" if $name eq "sockpair";
+ my $proto = prototype("CORE::$name");
+ if (defined $proto
+ && $proto =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $first = $self->deparse($kid->first, 6);
+ }
+ else {
+ $first = $self->deparse($kid, 6);
+ }
+ if ($name eq "chmod" && $first =~ /^\d+$/) {
+ $first = sprintf("%#o", $first);
+ }
+ $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ push @exprs, $first;
+ $kid = $kid->sibling;
+ if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
+ push @exprs, $self->deparse($kid->first, 6);
+ $kid = $kid->sibling;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
+ return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
+ }
+ if ($parens) {
+ return "$name(" . join(", ", @exprs) . ")";
+ } else {
+ return "$name " . join(", ", @exprs);
+ }
+}
+
+sub pp_bless { listop(@_, "bless") }
+sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
+sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_index { maybe_targmy(@_, \&listop, "index") }
+sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
+sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
+sub pp_formline { listop(@_, "formline") } # see also deparse_format
+sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
+sub pp_unpack { listop(@_, "unpack") }
+sub pp_pack { listop(@_, "pack") }
+sub pp_join { maybe_targmy(@_, \&listop, "join") }
+sub pp_splice { listop(@_, "splice") }
+sub pp_push { maybe_targmy(@_, \&listop, "push") }
+sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
+sub pp_reverse { listop(@_, "reverse") }
+sub pp_warn { listop(@_, "warn") }
+sub pp_die { listop(@_, "die") }
+# Actually, return is exempt from the LLAFR (see examples in this very
+# module!), but for consistency's sake, ignore that fact
+sub pp_return { listop(@_, "return") }
+sub pp_open { listop(@_, "open") }
+sub pp_pipe_op { listop(@_, "pipe") }
+sub pp_tie { listop(@_, "tie") }
+sub pp_binmode { listop(@_, "binmode") }
+sub pp_dbmopen { listop(@_, "dbmopen") }
+sub pp_sselect { listop(@_, "select") }
+sub pp_select { listop(@_, "select") }
+sub pp_read { listop(@_, "read") }
+sub pp_sysopen { listop(@_, "sysopen") }
+sub pp_sysseek { listop(@_, "sysseek") }
+sub pp_sysread { listop(@_, "sysread") }
+sub pp_syswrite { listop(@_, "syswrite") }
+sub pp_send { listop(@_, "send") }
+sub pp_recv { listop(@_, "recv") }
+sub pp_seek { listop(@_, "seek") }
+sub pp_fcntl { listop(@_, "fcntl") }
+sub pp_ioctl { listop(@_, "ioctl") }
+sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
+sub pp_socket { listop(@_, "socket") }
+sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_bind { listop(@_, "bind") }
+sub pp_connect { listop(@_, "connect") }
+sub pp_listen { listop(@_, "listen") }
+sub pp_accept { listop(@_, "accept") }
+sub pp_shutdown { listop(@_, "shutdown") }
+sub pp_gsockopt { listop(@_, "getsockopt") }
+sub pp_ssockopt { listop(@_, "setsockopt") }
+sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
+sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
+sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
+sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
+sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
+sub pp_link { maybe_targmy(@_, \&listop, "link") }
+sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
+sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
+sub pp_open_dir { listop(@_, "opendir") }
+sub pp_seekdir { listop(@_, "seekdir") }
+sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
+sub pp_system { maybe_targmy(@_, \&listop, "system") }
+sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
+sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
+sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
+sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
+sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
+sub pp_shmget { listop(@_, "shmget") }
+sub pp_shmctl { listop(@_, "shmctl") }
+sub pp_shmread { listop(@_, "shmread") }
+sub pp_shmwrite { listop(@_, "shmwrite") }
+sub pp_msgget { listop(@_, "msgget") }
+sub pp_msgctl { listop(@_, "msgctl") }
+sub pp_msgsnd { listop(@_, "msgsnd") }
+sub pp_msgrcv { listop(@_, "msgrcv") }
+sub pp_semget { listop(@_, "semget") }
+sub pp_semctl { listop(@_, "semctl") }
+sub pp_semop { listop(@_, "semop") }
+sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
+sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
+sub pp_gpbynumber { listop(@_, "getprotobynumber") }
+sub pp_gsbyname { listop(@_, "getservbyname") }
+sub pp_gsbyport { listop(@_, "getservbyport") }
+sub pp_syscall { listop(@_, "syscall") }
+
+sub pp_glob {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = $self->dq($op->first->sibling); # skip pushmark
+ if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
+ or $text =~ /[<>]/) {
+ return 'glob(' . single_delim('qq', '"', $text) . ')';
+ } else {
+ return '<' . $text . '>';
+ }
+}
+
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ my $fh;
+ if ($op->flags & OPf_SPECIAL) {
+ # $kid is an OP_CONST
+ $fh = $self->const_sv($kid)->PV;
+ } else {
+ $fh = $self->deparse($kid, 6);
+ $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+ }
+ my $len = $self->deparse($kid->sibling, 6);
+ if ($parens) {
+ return "truncate($fh, $len)";
+ } else {
+ return "truncate $fh, $len";
+ }
+}
+
+sub indirop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling;
+ my $indir = "";
+ if ($op->flags & OPf_STACKED) {
+ $indir = $kid;
+ $indir = $indir->first; # skip rv2gv
+ if (is_scope($indir)) {
+ $indir = "{" . $self->deparse($indir, 0) . "}";
+ $indir = "{;}" if $indir eq "{}";
+ } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
+ $indir = $self->const_sv($indir)->PV;
+ } else {
+ $indir = $self->deparse($indir, 24);
+ }
+ $indir = $indir . " ";
+ $kid = $kid->sibling;
+ }
+ if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
+ $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
+ : '{$a <=> $b} ';
+ }
+ elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
+ $indir = '{$b cmp $a} ';
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ my $name2 = $name;
+ if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ $name2 = 'reverse sort';
+ }
+ if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
+ return "$exprs[0] = $name2 $indir $exprs[0]";
+ }
+
+ my $args = $indir . join(", ", @exprs);
+ if ($indir ne "" and $name eq "sort") {
+ # We don't want to say "sort(f 1, 2, 3)", since perl -w will
+ # give bareword warnings in that case. Therefore if context
+ # requires, we'll put parens around the outside "(sort f 1, 2,
+ # 3)". Unfortunately, we'll currently think the parens are
+ # necessary more often that they really are, because we don't
+ # distinguish which side of an assignment we're on.
+ if ($cx >= 5) {
+ return "($name2 $args)";
+ } else {
+ return "$name2 $args";
+ }
+ } else {
+ return $self->maybe_parens_func($name2, $args, $cx, 5);
+ }
+
+}
+
+sub pp_prtf { indirop(@_, "printf") }
+sub pp_print { indirop(@_, "print") }
+sub pp_say { indirop(@_, "say") }
+sub pp_sort { indirop(@_, "sort") }
+
+sub mapop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first; # this is the (map|grep)start
+ $kid = $kid->first->sibling; # skip a pushmark
+ my $code = $kid->first; # skip a null
+ if (is_scope $code) {
+ $code = "{" . $self->deparse($code, 0) . "} ";
+ } else {
+ $code = $self->deparse($code, 24) . ", ";
+ }
+ $kid = $kid->sibling;
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr if defined $expr;
+ }
+ return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+}
+
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
+sub pp_mapstart { baseop(@_, "map") }
+sub pp_grepstart { baseop(@_, "grep") }
+
+sub pp_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling; # skip pushmark
+ my $lop;
+ my $local = "either"; # could be local(...), my(...), state(...) or our(...)
+ for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+ # This assumes that no other private flags equal 128, and that
+ # OPs that store things other than flags in their op_private,
+ # like OP_AELEMFAST, won't be immediate children of a list.
+ #
+ # OP_ENTERSUB can break this logic, so check for it.
+ # I suspect that open and exit can too.
+
+ if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
+ or $lop->name eq "undef")
+ or $lop->name eq "entersub"
+ or $lop->name eq "exit"
+ or $lop->name eq "open")
+ {
+ $local = ""; # or not
+ last;
+ }
+ if ($lop->name =~ /^pad[ash]v$/) {
+ if ($lop->private & OPpPAD_STATE) { # state()
+ ($local = "", last) if $local =~ /^(?:local|our|my)$/;
+ $local = "state";
+ } else { # my()
+ ($local = "", last) if $local =~ /^(?:local|our|state)$/;
+ $local = "my";
+ }
+ } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
+ && $lop->private & OPpOUR_INTRO
+ or $lop->name eq "null" && $lop->first->name eq "gvsv"
+ && $lop->first->private & OPpOUR_INTRO) { # our()
+ ($local = "", last) if $local =~ /^(?:my|local|state)$/;
+ $local = "our";
+ } elsif ($lop->name ne "undef"
+ # specifically avoid the "reverse sort" optimisation,
+ # where "reverse" is nullified
+ && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ {
+ # local()
+ ($local = "", last) if $local =~ /^(?:my|our|state)$/;
+ $local = "local";
+ }
+ }
+ $local = "" if $local eq "either"; # no point if it's all undefs
+ return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
+ for (; !null($kid); $kid = $kid->sibling) {
+ if ($local) {
+ if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
+ $lop = $kid->first;
+ } else {
+ $lop = $kid;
+ }
+ $self->{'avoid_local'}{$$lop}++;
+ $expr = $self->deparse($kid, 6);
+ delete $self->{'avoid_local'}{$$lop};
+ } else {
+ $expr = $self->deparse($kid, 6);
+ }
+ push @exprs, $expr;
+ }
+ if ($local) {
+ return "$local(" . join(", ", @exprs) . ")";
+ } else {
+ return $self->maybe_parens( join(", ", @exprs), $cx, 6);
+ }
+}
+
+sub is_ifelse_cont {
+ my $op = shift;
+ return ($op->name eq "null" and class($op) eq "UNOP"
+ and $op->first->name =~ /^(and|cond_expr)$/
+ and is_scope($op->first->first->sibling));
+}
+
+sub pp_cond_expr {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+ my $false = $true->sibling;
+ my $cuddle = $self->{'cuddle'};
+ unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
+ (is_scope($false) || is_ifelse_cont($false))
+ and $self->{'expand'} < 7) {
+ $cond = $self->deparse($cond, 8);
+ $true = $self->deparse($true, 6);
+ $false = $self->deparse($false, 8);
+ return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
+ }
+
+ $cond = $self->deparse($cond, 1);
+ $true = $self->deparse($true, 0);
+ my $head = "if ($cond) {\n\t$true\n\b}";
+ my @elsifs;
+ while (!null($false) and is_ifelse_cont($false)) {
+ my $newop = $false->first;
+ my $newcond = $newop->first;
+ my $newtrue = $newcond->sibling;
+ $false = $newtrue->sibling; # last in chain is OP_AND => no else
+ if ($newcond->name eq "lineseq")
+ {
+ # lineseq to ensure correct line numbers in elsif()
+ # Bug #37302 fixed by change #33710.
+ $newcond = $newcond->first->sibling;
+ }
+ $newcond = $self->deparse($newcond, 1);
+ $newtrue = $self->deparse($newtrue, 0);
+ push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ }
+ if (!null($false)) {
+ $false = $cuddle . "else {\n\t" .
+ $self->deparse($false, 0) . "\n\b}\cK";
+ } else {
+ $false = "\cK";
+ }
+ return $head . join($cuddle, "", @elsifs) . $false;
+}
+
+sub pp_once {
+ my ($self, $op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+
+ return $self->deparse($true, $cx);
+}
+
+sub loop_common {
+ my $self = shift;
+ my($op, $cx, $init) = @_;
+ my $enter = $op->first;
+ my $kid = $enter->sibling;
+ local(@$self{qw'curstash warnings hints hinthash'})
+ = @$self{qw'curstash warnings hints hinthash'};
+ my $head = "";
+ my $bare = 0;
+ my $body;
+ my $cond = undef;
+ if ($kid->name eq "lineseq") { # bare or infinite loop
+ if ($kid->last->name eq "unstack") { # infinite
+ $head = "while (1) "; # Can't use for(;;) if there's a continue
+ $cond = "";
+ } else {
+ $bare = 1;
+ }
+ $body = $kid;
+ } elsif ($enter->name eq "enteriter") { # foreach
+ my $ary = $enter->first->sibling; # first was pushmark
+ my $var = $ary->sibling;
+ if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
+ # "reverse" was optimised away
+ $ary = listop($self, $ary->first->sibling, 1, 'reverse');
+ } elsif ($enter->flags & OPf_STACKED
+ and not null $ary->first->sibling->sibling)
+ {
+ $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
+ $self->deparse($ary->first->sibling->sibling, 9);
+ } else {
+ $ary = $self->deparse($ary, 1);
+ }
+ if (null $var) {
+ if ($enter->flags & OPf_SPECIAL) { # thread special var
+ $var = $self->pp_threadsv($enter, 1);
+ } else { # regular my() variable
+ $var = $self->pp_padsv($enter, 1);
+ }
+ } elsif ($var->name eq "rv2gv") {
+ $var = $self->pp_rv2sv($var, 1);
+ if ($enter->private & OPpOUR_INTRO) {
+ # our declarations don't have package names
+ $var =~ s/^(.).*::/$1/;
+ $var = "our $var";
+ }
+ } elsif ($var->name eq "gv") {
+ $var = "\$" . $self->deparse($var, 1);
+ }
+ $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ if (!is_state $body->first and $body->first->name ne "stub") {
+ confess unless $var eq '$_';
+ $body = $body->first;
+ return $self->deparse($body, 2) . " foreach ($ary)";
+ }
+ $head = "foreach $var ($ary) ";
+ } elsif ($kid->name eq "null") { # while/until
+ $kid = $kid->first;
+ my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $self->deparse($kid->first, 1);
+ $head = "$name ($cond) ";
+ $body = $kid->first->sibling;
+ } elsif ($kid->name eq "stub") { # bare and empty
+ return "{;}"; # {} could be a hashref
+ }
+ # If there isn't a continue block, then the next pointer for the loop
+ # will point to the unstack, which is kid's last child, except
+ # in a bare loop, when it will point to the leaveloop. When neither of
+ # these conditions hold, then the second-to-last child is the continue
+ # block (or the last in a bare loop).
+ my $cont_start = $enter->nextop;
+ my $cont;
+ if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
+ if ($bare) {
+ $cont = $body->last;
+ } else {
+ $cont = $body->first;
+ while (!null($cont->sibling->sibling)) {
+ $cont = $cont->sibling;
+ }
+ }
+ my $state = $body->first;
+ my $cuddle = $self->{'cuddle'};
+ my @states;
+ for (; $$state != $$cont; $state = $state->sibling) {
+ push @states, $state;
+ }
+ $body = $self->lineseq(undef, @states);
+ if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+ $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $cont = "\cK";
+ } else {
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
+ }
+ } else {
+ return "" if !defined $body;
+ if (length $init) {
+ $head = "for ($init; $cond;) ";
+ }
+ $cont = "\cK";
+ $body = $self->deparse($body, 0);
+ }
+ $body =~ s/;?$/;\n/;
+
+ return $head . "{\n\t" . $body . "\b}" . $cont;
+}
+
+sub pp_leaveloop { shift->loop_common(@_, "") }
+
+sub for_loop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $init = $self->deparse($op, 1);
+ return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+}
+
+sub pp_leavetry {
+ my $self = shift;
+ return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
+}
+
+BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
+BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
+BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
+BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
+
+sub pp_null {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if (class($op) eq "OP") {
+ # old value is lost
+ return $self->{'ex_const'} if $op->targ == OP_CONST;
+ } elsif ($op->first->name eq "pushmark") {
+ return $self->pp_list($op, $cx);
+ } elsif ($op->first->name eq "enter") {
+ return $self->pp_leave($op, $cx);
+ } elsif ($op->first->name eq "leave") {
+ return $self->pp_leave($op->first, $cx);
+ } elsif ($op->first->name eq "scope") {
+ return $self->pp_scope($op->first, $cx);
+ } elsif ($op->targ == OP_STRINGIFY) {
+ return $self->dquote($op, $cx);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "readline" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 7) . " = "
+ . $self->deparse($op->first->sibling, 7),
+ $cx, 7);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "trans" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
+ . $self->deparse($op->first->sibling, 20),
+ $cx, 20);
+ } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
+ return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->name eq "null" and
+ class($op->first->sibling) eq "UNOP" and
+ $op->first->sibling->first->flags & OPf_STACKED and
+ $op->first->sibling->first->name eq "rcatline") {
+ return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
+ . $self->deparse($op->first->sibling, 18),
+ $cx, 18);
+ } else {
+ return $self->deparse($op->first, $cx);
+ }
+}
+
+sub padname {
+ my $self = shift;
+ my $targ = shift;
+ return $self->padname_sv($targ)->PVX;
+}
+
+sub padany {
+ my $self = shift;
+ my $op = shift;
+ return substr($self->padname($op->targ), 1); # skip $/@/%
+}
+
+sub pp_padsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_my($op, $cx, $self->padname($op->targ));
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+my @threadsv_names;
+
+BEGIN {
+ @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
+ "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
+ "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
+ "!", "@");
+}
+
+sub pp_threadsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
+}
+
+sub gv_or_padgv {
+ my $self = shift;
+ my $op = shift;
+ if (class($op) eq "PADOP") {
+ return $self->padval($op->padix);
+ } else { # class($op) eq "SVOP"
+ return $op->gv;
+ }
+}
+
+sub pp_gvsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->maybe_local($op, $cx, $self->stash_variable("\$",
+ $self->gv_name($gv)));
+}
+
+sub pp_gv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $self->gv_or_padgv($op);
+ return $self->gv_name($gv);
+}
+
+sub pp_aelemfast {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $name;
+ if ($op->flags & OPf_SPECIAL) { # optimised PADAV
+ $name = $self->padname($op->targ);
+ $name =~ s/^@/\$/;
+ }
+ else {
+ my $gv = $self->gv_or_padgv($op);
+ $name = $self->gv_name($gv);
+ $name = $self->{'curstash'}."::$name"
+ if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ $name = '$' . $name;
+ }
+
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+}
+
+sub rv2x {
+ my $self = shift;
+ my($op, $cx, $type) = @_;
+
+ if (class($op) eq 'NULL' || !$op->can("first")) {
+ carp("Unexpected op in pp_rv2x");
+ return 'XXX';
+ }
+ my $kid = $op->first;
+ if ($kid->name eq "gv") {
+ return $self->stash_variable($type, $self->deparse($kid, 0));
+ } elsif (is_scalar $kid) {
+ my $str = $self->deparse($kid, 0);
+ if ($str =~ /^\$([^\w\d])\z/) {
+ # "$$+" isn't a legal way to write the scalar dereference
+ # of $+, since the lexer can't tell you aren't trying to
+ # do something like "$$ + 1" to get one more than your
+ # PID. Either "${$+}" or "$${+}" are workable
+ # disambiguations, but if the programmer did the former,
+ # they'd be in the "else" clause below rather than here.
+ # It's not clear if this should somehow be unified with
+ # the code in dq and re_dq that also adds lexer
+ # disambiguation braces.
+ $str = '$' . "{$1}"; #'
+ }
+ return $type . $str;
+ } else {
+ return $type . "{" . $self->deparse($kid, 0) . "}";
+ }
+}
+
+sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
+sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
+sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
+
+# skip rv2av
+sub pp_av2arylen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->name eq "padav") {
+ return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
+ } else {
+ return $self->maybe_local($op, $cx,
+ $self->rv2x($op->first, $cx, '$#'));
+ }
+}
+
+# skip down to the old, ex-rv2cv
+sub pp_rv2cv {
+ my ($self, $op, $cx) = @_;
+ if (!null($op->first) && $op->first->name eq 'null' &&
+ $op->first->targ eq OP_LIST)
+ {
+ return $self->rv2x($op->first->first->sibling, $cx, "&")
+ }
+ else {
+ return $self->rv2x($op, $cx, "")
+ }
+}
+
+sub list_const {
+ my $self = shift;
+ my($cx, @list) = @_;
+ my @a = map $self->const($_, 6), @list;
+ if (@a == 0) {
+ return "()";
+ } elsif (@a == 1) {
+ return $a[0];
+ } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
+ # collapse (-1,0,1,2) into (-1..2)
+ my ($s, $e) = @a[0,-1];
+ my $i = $s;
+ return $self->maybe_parens("$s..$e", $cx, 9)
+ unless grep $i++ != $_, @a;
+ }
+ return $self->maybe_parens(join(", ", @a), $cx, 6);
+}
+
+sub pp_rv2av {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->name eq "const") { # constant list
+ my $av = $self->const_sv($kid);
+ return $self->list_const($cx, $av->ARRAY);
+ } else {
+ return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
+ }
+ }
+
+sub is_subscriptable {
+ my $op = shift;
+ if ($op->name =~ /^[ahg]elem/) {
+ return 1;
+ } elsif ($op->name eq "entersub") {
+ my $kid = $op->first;
+ return 0 unless null $kid->sibling;
+ $kid = $kid->first;
+ $kid = $kid->sibling until null $kid->sibling;
+ return 0 if is_scope($kid);
+ $kid = $kid->first;
+ return 0 if $kid->name eq "gv";
+ return 0 if is_scalar($kid);
+ return is_subscriptable($kid);
+ } else {
+ return 0;
+ }
+}
+
+sub elem_or_slice_array_name
+{
+ my $self = shift;
+ my ($array, $left, $padname, $allow_arrow) = @_;
+
+ if ($array->name eq $padname) {
+ return $self->padany($array);
+ } elsif (is_scope($array)) { # ${expr}[0]
+ return "{" . $self->deparse($array, 0) . "}";
+ } elsif ($array->name eq "gv") {
+ $array = $self->gv_name($self->gv_or_padgv($array));
+ if ($array !~ /::/) {
+ my $prefix = ($left eq '[' ? '@' : '%');
+ $array = $self->{curstash}.'::'.$array
+ if $self->lex_in_scope($prefix . $array);
+ }
+ return $array;
+ } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
+ return $self->deparse($array, 24);
+ } else {
+ return undef;
+ }
+}
+
+sub elem_or_slice_single_index
+{
+ my $self = shift;
+ my ($idx) = @_;
+
+ $idx = $self->deparse($idx, 1);
+
+ # Outer parens in an array index will confuse perl
+ # if we're interpolating in a regular expression, i.e.
+ # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
+ #
+ # If $self->{parens}, then an initial '(' will
+ # definitely be paired with a final ')'. If
+ # !$self->{parens}, the misleading parens won't
+ # have been added in the first place.
+ #
+ # [You might think that we could get "(...)...(...)"
+ # where the initial and final parens do not match
+ # each other. But we can't, because the above would
+ # only happen if there's an infix binop between the
+ # two pairs of parens, and *that* means that the whole
+ # expression would be parenthesized as well.]
+ #
+ $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
+
+ # Hash-element braces will autoquote a bareword inside themselves.
+ # We need to make sure that C<$hash{warn()}> doesn't come out as
+ # C<$hash{warn}>, which has a quite different meaning. Currently
+ # B::Deparse will always quote strings, even if the string was a
+ # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
+ # for constant strings.) So we can cheat slightly here - if we see
+ # a bareword, we know that it is supposed to be a function call.
+ #
+ $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
+
+ return $idx;
+}
+
+sub elem {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $padname) = @_;
+ my($array, $idx) = ($op->first, $op->first->sibling);
+
+ $idx = $self->elem_or_slice_single_index($idx);
+
+ unless ($array->name eq $padname) { # Maybe this has been fixed
+ $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+ }
+ if (my $array_name=$self->elem_or_slice_array_name
+ ($array, $left, $padname, 1)) {
+ return "\$" . $array_name . $left . $idx . $right;
+ } else {
+ # $x[20][3]{hi} or expr->[20]
+ my $arrow = is_subscriptable($array) ? "" : "->";
+ return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
+ }
+
+}
+
+sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
+sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
+
+sub pp_gelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($glob, $part) = ($op->first, $op->last);
+ $glob = $glob->first; # skip rv2gv
+ $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
+ my $scope = is_scope($glob);
+ $glob = $self->deparse($glob, 0);
+ $part = $self->deparse($part, 1);
+ return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
+}
+
+sub slice {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $regname, $padname) = @_;
+ my $last;
+ my(@elems, $kid, $array, $list);
+ if (class($op) eq "LISTOP") {
+ $last = $op->last;
+ } else { # ex-hslice inside delete()
+ for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
+ $last = $kid;
+ }
+ $array = $last;
+ $array = $array->first
+ if $array->name eq $regname or $array->name eq "null";
+ $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
+ $kid = $op->first->sibling; # skip pushmark
+ if ($kid->name eq "list") {
+ $kid = $kid->first->sibling; # skip list, pushmark
+ for (; !null $kid; $kid = $kid->sibling) {
+ push @elems, $self->deparse($kid, 6);
+ }
+ $list = join(", ", @elems);
+ } else {
+ $list = $self->elem_or_slice_single_index($kid);
+ }
+ return "\@" . $array . $left . $list . $right;
+}
+
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+
+sub pp_lslice {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $idx = $op->first;
+ my $list = $op->last;
+ my(@elems, $kid);
+ $list = $self->deparse($list, 1);
+ $idx = $self->deparse($idx, 1);
+ return "($list)" . "[$idx]";
+}
+
+sub want_scalar {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
+}
+
+sub want_list {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
+}
+
+sub _method {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip pushmark
+ my($meth, $obj, @exprs);
+ if ($kid->name eq "list" and want_list $kid) {
+ # When an indirect object isn't a bareword but the args are in
+ # parens, the parens aren't part of the method syntax (the LLAFR
+ # doesn't apply), but they make a list with OPf_PARENS set that
+ # doesn't get flattened by the append_elem that adds the method,
+ # making a (object, arg1, arg2, ...) list where the object
+ # usually is. This can be distinguished from
+ # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+ # object) because in the later the list is in scalar context
+ # as the left side of -> always is, while in the former
+ # the list is in list context as method arguments always are.
+ # (Good thing there aren't method prototypes!)
+ $meth = $kid->sibling;
+ $kid = $kid->first->sibling; # skip pushmark
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ } else {
+ $obj = $kid;
+ $kid = $kid->sibling;
+ for (; !null ($kid->sibling) && $kid->name ne "method_named";
+ $kid = $kid->sibling) {
+ push @exprs, $kid
+ }
+ $meth = $kid;
+ }
+
+ if ($meth->name eq "method_named") {
+ $meth = $self->const_sv($meth)->PV;
+ } else {
+ $meth = $meth->first;
+ if ($meth->name eq "const") {
+ # As of 5.005_58, this case is probably obsoleted by the
+ # method_named case above
+ $meth = $self->const_sv($meth)->PV; # needs to be bare
+ }
+ }
+
+ return { method => $meth, variable_method => ref($meth),
+ object => $obj, args => \@exprs };
+}
+
+# compat function only
+sub method {
+ my $self = shift;
+ my $info = $self->_method(@_);
+ return $self->e_method( $self->_method(@_) );
+}
+
+sub e_method {
+ my ($self, $info) = @_;
+ my $obj = $self->deparse($info->{object}, 24);
+
+ my $meth = $info->{method};
+ $meth = $self->deparse($meth, 1) if $info->{variable_method};
+ my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ my $kid = $obj . "->" . $meth;
+ if (length $args) {
+ return $kid . "(" . $args . ")"; # parens mandatory
+ } else {
+ return $kid;
+ }
+}
+
+# returns "&" if the prototype doesn't match the args,
+# or ("", $args_after_prototype_demunging) if it does.
+sub check_proto {
+ my $self = shift;
+ return "&" if $self->{'noproto'};
+ my($proto, @args) = @_;
+ my($arg, $real);
+ my $doneok = 0;
+ my @reals;
+ # An unbackslashed @ or % gobbles up the rest of the args
+ 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+ while ($proto) {
+ $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
+ my $chr = $1;
+ if ($chr eq "") {
+ return "&" if @args;
+ } elsif ($chr eq ";") {
+ $doneok = 1;
+ } elsif ($chr eq "@" or $chr eq "%") {
+ push @reals, map($self->deparse($_, 6), @args);
+ @args = ();
+ } else {
+ $arg = shift @args;
+ last unless $arg;
+ if ($chr eq "\$" || $chr eq "_") {
+ if (want_scalar $arg) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "&") {
+ if ($arg->name =~ /^(s?refgen|undef)$/) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ return "&";
+ }
+ } elsif ($chr eq "*") {
+ if ($arg->name =~ /^s?refgen$/
+ and $arg->first->first->name eq "rv2gv")
+ {
+ $real = $arg->first->first; # skip refgen, null
+ if ($real->first->name eq "gv") {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ push @reals, $self->deparse($real->first, 6);
+ }
+ } else {
+ return "&";
+ }
+ } elsif (substr($chr, 0, 1) eq "\\") {
+ $chr =~ tr/\\[]//d;
+ if ($arg->name =~ /^s?refgen$/ and
+ !null($real = $arg->first) and
+ ($chr =~ /\$/ && is_scalar($real->first)
+ or ($chr =~ /@/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)av$/)
+ or ($chr =~ /%/
+ && class($real->first->sibling) ne 'NULL'
+ && $real->first->sibling->name
+ =~ /^(rv2|pad)hv$/)
+ #or ($chr =~ /&/ # This doesn't work
+ # && $real->first->name eq "rv2cv")
+ or ($chr =~ /\*/
+ && $real->first->name eq "rv2gv")))
+ {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ return "&";
+ }
+ }
+ }
+ }
+ return "&" if $proto and !$doneok; # too few args and no `;'
+ return "&" if @args; # too many args
+ return ("", join ", ", @reals);
+}
+
+sub pp_entersub {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->e_method($self->_method($op, $cx))
+ unless null $op->first->sibling;
+ my $prefix = "";
+ my $amper = "";
+ my($kid, @exprs);
+ if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
+ $prefix = "do ";
+ } elsif ($op->private & OPpENTERSUB_AMPER) {
+ $amper = "&";
+ }
+ $kid = $op->first;
+ $kid = $kid->first->sibling; # skip ex-list, pushmark
+ for (; not null $kid->sibling; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ my $simple = 0;
+ my $proto = undef;
+ if (is_scope($kid)) {
+ $amper = "&";
+ $kid = "{" . $self->deparse($kid, 0) . "}";
+ } elsif ($kid->first->name eq "gv") {
+ my $gv = $self->gv_or_padgv($kid->first);
+ if (class($gv->CV) ne "SPECIAL") {
+ $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ }
+ $simple = 1; # only calls of named functions can be prototyped
+ $kid = $self->deparse($kid, 24);
+ if (!$amper) {
+ if ($kid eq 'main::') {
+ $kid = '::';
+ } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ $kid = single_delim("q", "'", $kid) . '->';
+ }
+ }
+ } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
+ $amper = "&";
+ $kid = $self->deparse($kid, 24);
+ } else {
+ $prefix = "";
+ my $arrow = is_subscriptable($kid->first) ? "" : "->";
+ $kid = $self->deparse($kid, 24) . $arrow;
+ }
+
+ # Doesn't matter how many prototypes there are, if
+ # they haven't happened yet!
+ my $declared;
+ {
+ no strict 'refs';
+ no warnings 'uninitialized';
+ $declared = exists $self->{'subs_declared'}{$kid}
+ || (
+ defined &{ ${$self->{'curstash'}."::"}{$kid} }
+ && !exists
+ $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
+ && defined prototype $self->{'curstash'}."::".$kid
+ );
+ if (!$declared && defined($proto)) {
+ # Avoid "too early to check prototype" warning
+ ($amper, $proto) = ('&');
+ }
+ }
+
+ my $args;
+ if ($declared and defined $proto and not $amper) {
+ ($amper, $args) = $self->check_proto($proto, @exprs);
+ if ($amper eq "&") {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ } else {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ if ($prefix or $amper) {
+ if ($op->flags & OPf_STACKED) {
+ return $prefix . $amper . $kid . "(" . $args . ")";
+ } else {
+ return $prefix . $amper. $kid;
+ }
+ } else {
+ # glob() invocations can be translated into calls of
+ # CORE::GLOBAL::glob with a second parameter, a number.
+ # Reverse this.
+ if ($kid eq "CORE::GLOBAL::glob") {
+ $kid = "glob";
+ $args =~ s/\s*,[^,]+$//;
+ }
+
+ # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
+ # so it must have been translated from a keyword call. Translate
+ # it back.
+ $kid =~ s/^CORE::GLOBAL:://;
+
+ my $dproto = defined($proto) ? $proto : "undefined";
+ if (!$declared) {
+ return "$kid(" . $args . ")";
+ } elsif ($dproto eq "") {
+ return $kid;
+ } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
+ # is_scalar is an excessively conservative test here:
+ # really, we should be comparing to the precedence of the
+ # top operator of $exprs[0] (ala unop()), but that would
+ # take some major code restructuring to do right.
+ return $self->maybe_parens_func($kid, $args, $cx, 16);
+ } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
+ return $self->maybe_parens_func($kid, $args, $cx, 5);
+ } else {
+ return "$kid(" . $args . ")";
+ }
+ }
+}
+
+sub pp_enterwrite { unop(@_, "write") }
+
+# escape things that cause interpolation in double quotes,
+# but not character escapes
+sub uninterp {
+ my($str) = @_;
+ $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
+ return $str;
+}
+
+{
+my $bal;
+BEGIN {
+ use re "eval";
+ # Matches any string which is balanced with respect to {braces}
+ $bal = qr(
+ (?:
+ [^\\{}]
+ | \\\\
+ | \\[{}]
+ | \{(??{$bal})\}
+ )*
+ )x;
+}
+
+# the same, but treat $|, $), $( and $ at the end of the string differently
+sub re_uninterp {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ (\(\?\??\{$bal\}\)) # $4
+ | [\$\@]
+ (?!\||\)|\(|$)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+
+# This is for regular expressions with the /x modifier
+# We have to leave comments unmangled.
+sub re_uninterp_extended {
+ my($str) = @_;
+
+ $str =~ s/
+ ( ^|\G # $1
+ | [^\\]
+ )
+
+ ( # $2
+ (?:\\\\)*
+ )
+
+ ( # $3
+ ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
+ | \#[^\n]* # (skip over comments)
+ )
+ | [\$\@]
+ (?!\||\)|\(|$|\s)
+ | \\[uUlLQE]
+ )
+
+ /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+}
+}
+
+my %unctrl = # portable to to EBCDIC
+ (
+ "\c@" => '\c@', # unused
+ "\cA" => '\cA',
+ "\cB" => '\cB',
+ "\cC" => '\cC',
+ "\cD" => '\cD',
+ "\cE" => '\cE',
+ "\cF" => '\cF',
+ "\cG" => '\cG',
+ "\cH" => '\cH',
+ "\cI" => '\cI',
+ "\cJ" => '\cJ',
+ "\cK" => '\cK',
+ "\cL" => '\cL',
+ "\cM" => '\cM',
+ "\cN" => '\cN',
+ "\cO" => '\cO',
+ "\cP" => '\cP',
+ "\cQ" => '\cQ',
+ "\cR" => '\cR',
+ "\cS" => '\cS',
+ "\cT" => '\cT',
+ "\cU" => '\cU',
+ "\cV" => '\cV',
+ "\cW" => '\cW',
+ "\cX" => '\cX',
+ "\cY" => '\cY',
+ "\cZ" => '\cZ',
+ "\c[" => '\c[', # unused
+ "\c\\" => '\c\\', # unused
+ "\c]" => '\c]', # unused
+ "\c_" => '\c_', # unused
+ );
+
+# character escapes, but not delimiters that might need to be escaped
+sub escape_str { # ASCII, UTF8
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/\a/\\a/g;
+# $str =~ s/\cH/\\b/g; # \b means something different in a regex
+ $str =~ s/\t/\\t/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
+ $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
+ return $str;
+}
+
+# For regexes with the /x modifier.
+# Leave whitespace unmangled.
+sub escape_extended_re {
+ my($str) = @_;
+ $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+ $str =~ s/([[:^print:]])/
+ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
+ $str =~ s/\n/\n\f/g;
+ return $str;
+}
+
+# Don't do this for regexen
+sub unback {
+ my($str) = @_;
+ $str =~ s/\\/\\\\/g;
+ return $str;
+}
+
+# Remove backslashes which precede literal control characters,
+# to avoid creating ambiguity when we escape the latter.
+sub re_unback {
+ my($str) = @_;
+
+ # the insane complexity here is due to the behaviour of "\c\"
+ $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
+ return $str;
+}
+
+sub balanced_delim {
+ my($str) = @_;
+ my @str = split //, $str;
+ my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
+ for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
+ ($open, $close) = @$ar;
+ $fail = 0; $cnt = 0; $last_bs = 0;
+ for $c (@str) {
+ if ($c eq $open) {
+ $fail = 1 if $last_bs;
+ $cnt++;
+ } elsif ($c eq $close) {
+ $fail = 1 if $last_bs;
+ $cnt--;
+ if ($cnt < 0) {
+ # qq()() isn't ")("
+ $fail = 1;
+ last;
+ }
+ }
+ $last_bs = $c eq '\\';
+ }
+ $fail = 1 if $cnt != 0;
+ return ($open, "$open$str$close") if not $fail;
+ }
+ return ("", $str);
+}
+
+sub single_delim {
+ my($q, $default, $str) = @_;
+ return "$default$str$default" if $default and index($str, $default) == -1;
+ if ($q ne 'qr') {
+ (my $succeed, $str) = balanced_delim($str);
+ return "$q$str" if $succeed;
+ }
+ for my $delim ('/', '"', '#') {
+ return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ }
+ if ($default) {
+ $str =~ s/$default/\\$default/g;
+ return "$default$str$default";
+ } else {
+ $str =~ s[/][\\/]g;
+ return "$q/$str/";
+ }
+}
+
+my $max_prec;
+BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
+
+# Split a floating point number into an integer mantissa and a binary
+# exponent. Assumes you've already made sure the number isn't zero or
+# some weird infinity or NaN.
+sub split_float {
+ my($f) = @_;
+ my $exponent = 0;
+ if ($f == int($f)) {
+ while ($f % 2 == 0) {
+ $f /= 2;
+ $exponent++;
+ }
+ } else {
+ while ($f != int($f)) {
+ $f *= 2;
+ $exponent--;
+ }
+ }
+ my $mantissa = sprintf("%.0f", $f);
+ return ($mantissa, $exponent);
+}
+
+sub const {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ if ($self->{'use_dumper'}) {
+ return $self->const_dumper($sv, $cx);
+ }
+ if (class($sv) eq "SPECIAL") {
+ # sv_undef, sv_yes, sv_no
+ return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
+ }
+ if (class($sv) eq "NULL") {
+ return 'undef';
+ }
+ # convert a version object into the "v1.2.3" string in its V magic
+ if ($sv->FLAGS & SVs_RMG) {
+ for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ return $mg->PTR if $mg->TYPE eq 'V';
+ }
+ }
+
+ if ($sv->FLAGS & SVf_IOK) {
+ my $str = $sv->int_value;
+ $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ my $nv = $sv->NV;
+ if ($nv == 0) {
+ if (pack("F", $nv) eq pack("F", 0)) {
+ # positive zero
+ return "0";
+ } else {
+ # negative zero
+ return $self->maybe_parens("-.0", $cx, 21);
+ }
+ } elsif (1/$nv == 0) {
+ if ($nv > 0) {
+ # positive infinity
+ return $self->maybe_parens("9**9**9", $cx, 22);
+ } else {
+ # negative infinity
+ return $self->maybe_parens("-9**9**9", $cx, 21);
+ }
+ } elsif ($nv != $nv) {
+ # NaN
+ if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
+ # the normal kind
+ return "sin(9**9**9)";
+ } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
+ # the inverted kind
+ return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
+ } else {
+ # some other kind
+ my $hex = unpack("h*", pack("F", $nv));
+ return qq'unpack("F", pack("h*", "$hex"))';
+ }
+ }
+ # first, try the default stringification
+ my $str = "$nv";
+ if ($str != $nv) {
+ # failing that, try using more precision
+ $str = sprintf("%.${max_prec}g", $nv);
+# if (pack("F", $str) ne pack("F", $nv)) {
+ if ($str != $nv) {
+ # not representable in decimal with whatever sprintf()
+ # and atof() Perl is using here.
+ my($mant, $exp) = split_float($nv);
+ return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
+ }
+ }
+ $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
+ return $str;
+ } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
+ my $ref = $sv->RV;
+ if (class($ref) eq "AV") {
+ return "[" . $self->list_const(2, $ref->ARRAY) . "]";
+ } elsif (class($ref) eq "HV") {
+ my %hash = $ref->ARRAY;
+ my @elts;
+ for my $k (sort keys %hash) {
+ push @elts, "$k => " . $self->const($hash{$k}, 6);
+ }
+ return "{" . join(", ", @elts) . "}";
+ } elsif (class($ref) eq "CV") {
+ return "sub " . $self->deparse_sub($ref);
+ }
+ if ($ref->FLAGS & SVs_SMG) {
+ for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+ if ($mg->TYPE eq 'r') {
+ my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
+ return single_delim("qr", "", $re);
+ }
+ }
+ }
+
+ return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
+ } elsif ($sv->FLAGS & SVf_POK) {
+ my $str = $sv->PV;
+ if ($str =~ /[[:^print:]]/) {
+ return single_delim("qq", '"', uninterp escape_str unback $str);
+ } else {
+ return single_delim("q", "'", unback $str);
+ }
+ } else {
+ return "undef";
+ }
+}
+
+sub const_dumper {
+ my $self = shift;
+ my($sv, $cx) = @_;
+ my $ref = $sv->object_2svref();
+ my $dumper = Data::Dumper->new([$$ref], ['$v']);
+ $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
+ my $str = $dumper->Dump();
+ if ($str =~ /^\$v/) {
+ return '${my ' . $str . ' \$v}';
+ } else {
+ return $str;
+ }
+}
+
+sub const_sv {
+ my $self = shift;
+ my $op = shift;
+ my $sv = $op->sv;
+ # the constant could be in the pad (under useithreads)
+ $sv = $self->padval($op->targ) unless $$sv;
+ return $sv;
+}
+
+sub pp_const {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->private & OPpCONST_ARYBASE) {
+ return '$[';
+ }
+# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
+# return $self->const_sv($op)->PV;
+# }
+ my $sv = $self->const_sv($op);
+ return $self->const($sv, $cx);
+}
+
+sub dq {
+ my $self = shift;
+ my $op = shift;
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
+ } elsif ($type eq "concat") {
+ my $first = $self->dq($op->first);
+ my $last = $self->dq($op->last);
+
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[:'{\[\w_]/ && #'
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+
+ return $first . $last;
+ } elsif ($type eq "uc") {
+ return '\U' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->dq($op->first->sibling);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->dq($op->first->sibling);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pp_backtick {
+ my $self = shift;
+ my($op, $cx) = @_;
+ # skip pushmark if it exists (readpipe() vs ``)
+ my $child = $op->first->sibling->isa('B::NULL')
+ ? $op->first : $op->first->sibling;
+ return single_delim("qx", '`', $self->dq($child));
+}
+
+sub dquote {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first->sibling; # skip ex-stringify, pushmark
+ return $self->deparse($kid, $cx) if $self->{'unquote'};
+ $self->maybe_targmy($kid, $cx,
+ sub {single_delim("qq", '"', $self->dq($_[1]))});
+}
+
+# OP_STRINGIFY is a listop, but it only ever has one arg
+sub pp_stringify { maybe_targmy(@_, \&dquote) }
+
+# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
+# note that tr(from)/to/ is OK, but not tr/from/(to)
+sub double_delim {
+ my($from, $to) = @_;
+ my($succeed, $delim);
+ if ($from !~ m[/] and $to !~ m[/]) {
+ return "/$from/$to/";
+ } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
+ if (($succeed, $to) = balanced_delim($to) and $succeed) {
+ return "$from$to";
+ } else {
+ for $delim ('/', '"', '#') { # note no `'' -- s''' is special
+ return "$from$delim$to$delim" if index($to, $delim) == -1;
+ }
+ $to =~ s[/][\\/]g;
+ return "$from/$to/";
+ }
+ } else {
+ for $delim ('/', '"', '#') { # note no '
+ return "$delim$from$delim$to$delim"
+ if index($to . $from, $delim) == -1;
+ }
+ $from =~ s[/][\\/]g;
+ $to =~ s[/][\\/]g;
+ return "/$from/$to/";
+ }
+}
+
+# Only used by tr///, so backslashes hyphens
+sub pchr { # ASCII
+ my($n) = @_;
+ if ($n == ord '\\') {
+ return '\\\\';
+ } elsif ($n == ord "-") {
+ return "\\-";
+ } elsif ($n >= ord(' ') and $n <= ord('~')) {
+ return chr($n);
+ } elsif ($n == ord "\a") {
+ return '\\a';
+ } elsif ($n == ord "\b") {
+ return '\\b';
+ } elsif ($n == ord "\t") {
+ return '\\t';
+ } elsif ($n == ord "\n") {
+ return '\\n';
+ } elsif ($n == ord "\e") {
+ return '\\e';
+ } elsif ($n == ord "\f") {
+ return '\\f';
+ } elsif ($n == ord "\r") {
+ return '\\r';
+ } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
+ return '\\c' . chr(ord("@") + $n);
+ } else {
+# return '\x' . sprintf("%02x", $n);
+ return '\\' . sprintf("%03o", $n);
+ }
+}
+
+sub collapse {
+ my(@chars) = @_;
+ my($str, $c, $tr) = ("");
+ for ($c = 0; $c < @chars; $c++) {
+ $tr = $chars[$c];
+ $str .= pchr($tr);
+ if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
+ $chars[$c + 2] == $tr + 2)
+ {
+ for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
+ {}
+ $str .= "-";
+ $str .= pchr($chars[$c]);
+ }
+ }
+ return $str;
+}
+
+sub tr_decode_byte {
+ my($table, $flags) = @_;
+ my(@table) = unpack("s*", $table);
+ splice @table, 0x100, 1; # Number of subsequent elements
+ my($c, $tr, @from, @to, @delfrom, $delhyphen);
+ if ($table[ord "-"] != -1 and
+ $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
+ {
+ $tr = $table[ord "-"];
+ $table[ord "-"] = -1;
+ if ($tr >= 0) {
+ @from = ord("-");
+ @to = $tr;
+ } else { # -2 ==> delete
+ $delhyphen = 1;
+ }
+ }
+ for ($c = 0; $c < @table; $c++) {
+ $tr = $table[$c];
+ if ($tr >= 0) {
+ push @from, $c; push @to, $tr;
+ } elsif ($tr == -2) {
+ push @delfrom, $c;
+ }
+ }
+ @from = (@from, @delfrom);
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom = ();
+ my %from;
+ @from{@from} = (1) x @from;
+ for ($c = 0; $c < 256; $c++) {
+ push @newfrom, $c unless $from{$c};
+ }
+ @from = @newfrom;
+ }
+ unless ($flags & OPpTRANS_DELETE || !@to) {
+ pop @to while $#to and $to[$#to] == $to[$#to -1];
+ }
+ my($from, $to);
+ $from = collapse(@from);
+ $to = collapse(@to);
+ $from .= "-" if $delhyphen;
+ return ($from, $to);
+}
+
+sub tr_chr {
+ my $x = shift;
+ if ($x == ord "-") {
+ return "\\-";
+ } elsif ($x == ord "\\") {
+ return "\\\\";
+ } else {
+ return chr $x;
+ }
+}
+
+# XXX This doesn't yet handle all cases correctly either
+
+sub tr_decode_utf8 {
+ my($swash_hv, $flags) = @_;
+ my %swash = $swash_hv->ARRAY;
+ my $final = undef;
+ $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
+ my $none = $swash{"NONE"}->IV;
+ my $extra = $none + 1;
+ my(@from, @delfrom, @to);
+ my $line;
+ foreach $line (split /\n/, $swash{'LIST'}->PV) {
+ my($min, $max, $result) = split(/\t/, $line);
+ $min = hex $min;
+ if (length $max) {
+ $max = hex $max;
+ } else {
+ $max = $min;
+ }
+ $result = hex $result;
+ if ($result == $extra) {
+ push @delfrom, [$min, $max];
+ } else {
+ push @from, [$min, $max];
+ push @to, [$result, $result + $max - $min];
+ }
+ }
+ for my $i (0 .. $#from) {
+ if ($from[$i][0] == ord '-') {
+ unshift @from, splice(@from, $i, 1);
+ unshift @to, splice(@to, $i, 1);
+ last;
+ } elsif ($from[$i][1] == ord '-') {
+ $from[$i][1]--;
+ $to[$i][1]--;
+ unshift @from, ord '-';
+ unshift @to, ord '-';
+ last;
+ }
+ }
+ for my $i (0 .. $#delfrom) {
+ if ($delfrom[$i][0] == ord '-') {
+ push @delfrom, splice(@delfrom, $i, 1);
+ last;
+ } elsif ($delfrom[$i][1] == ord '-') {
+ $delfrom[$i][1]--;
+ push @delfrom, ord '-';
+ last;
+ }
+ }
+ if (defined $final and $to[$#to][1] != $final) {
+ push @to, [$final, $final];
+ }
+ push @from, @delfrom;
+ if ($flags & OPpTRANS_COMPLEMENT) {
+ my @newfrom;
+ my $next = 0;
+ for my $i (0 .. $#from) {
+ push @newfrom, [$next, $from[$i][0] - 1];
+ $next = $from[$i][1] + 1;
+ }
+ @from = ();
+ for my $range (@newfrom) {
+ if ($range->[0] <= $range->[1]) {
+ push @from, $range;
+ }
+ }
+ }
+ my($from, $to, $diff);
+ for my $chunk (@from) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $from .= tr_chr($chunk->[0]);
+ }
+ }
+ for my $chunk (@to) {
+ $diff = $chunk->[1] - $chunk->[0];
+ if ($diff > 1) {
+ $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
+ } elsif ($diff == 1) {
+ $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
+ } else {
+ $to .= tr_chr($chunk->[0]);
+ }
+ }
+ #$final = sprintf("%04x", $final) if defined $final;
+ #$none = sprintf("%04x", $none) if defined $none;
+ #$extra = sprintf("%04x", $extra) if defined $extra;
+ #print STDERR "final: $final\n none: $none\nextra: $extra\n";
+ #print STDERR $swash{'LIST'}->PV;
+ return (escape_str($from), escape_str($to));
+}
+
+sub pp_trans {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($from, $to);
+ if (class($op) eq "PVOP") {
+ ($from, $to) = tr_decode_byte($op->pv, $op->private);
+ } else { # class($op) eq "SVOP"
+ ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
+ $flags .= "d" if $op->private & OPpTRANS_DELETE;
+ $to = "" if $from eq $to and $flags eq "";
+ $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ return "tr" . double_delim($from, $to) . $flags;
+}
+
+sub re_dq_disambiguate {
+ my ($first, $last) = @_;
+ # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
+ ($last =~ /^[A-Z\\\^\[\]_?]/ &&
+ $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
+ || ($last =~ /^[{\[\w_]/ &&
+ $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
+ return $first . $last;
+}
+
+# Like dq(), but different
+sub re_dq {
+ my $self = shift;
+ my ($op, $extended) = @_;
+
+ my $type = $op->name;
+ if ($type eq "const") {
+ return '$[' if $op->private & OPpCONST_ARYBASE;
+ my $unbacked = re_unback($self->const_sv($op)->as_string);
+ return re_uninterp_extended(escape_extended_re($unbacked))
+ if $extended;
+ return re_uninterp(escape_str($unbacked));
+ } elsif ($type eq "concat") {
+ my $first = $self->re_dq($op->first, $extended);
+ my $last = $self->re_dq($op->last, $extended);
+ return re_dq_disambiguate($first, $last);
+ } elsif ($type eq "uc") {
+ return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "lc") {
+ return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "ucfirst") {
+ return '\u' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "lcfirst") {
+ return '\l' . $self->re_dq($op->first->sibling, $extended);
+ } elsif ($type eq "quotemeta") {
+ return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
+ } elsif ($type eq "join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pure_string {
+ my ($self, $op) = @_;
+ return 0 if null $op;
+ my $type = $op->name;
+
+ if ($type eq 'const') {
+ return 1;
+ }
+ elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
+ return $self->pure_string($op->first->sibling);
+ }
+ elsif ($type eq 'join') {
+ my $join_op = $op->first->sibling; # Skip pushmark
+ return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+
+ my $gvop = $join_op->first;
+ return 0 unless $gvop->name eq 'gvsv';
+ return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
+
+ return 0 unless ${$join_op->sibling} eq ${$op->last};
+ return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
+ }
+ elsif ($type eq 'concat') {
+ return $self->pure_string($op->first)
+ && $self->pure_string($op->last);
+ }
+ elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
+ return 1;
+ }
+ elsif ($type eq "null" and $op->can('first') and not null $op->first and
+ $op->first->name eq "null" and $op->first->can('first')
+ and not null $op->first->first and
+ $op->first->first->name eq "aelemfast") {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub regcomp {
+ my $self = shift;
+ my($op, $cx, $extended) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->name eq "regcmaybe";
+ $kid = $kid->first if $kid->name eq "regcreset";
+ if ($kid->name eq "null" and !null($kid->first)
+ and $kid->first->name eq 'pushmark')
+ {
+ my $str = '';
+ $kid = $kid->first->sibling;
+ while (!null($kid)) {
+ my $first = $str;
+ my $last = $self->re_dq($kid, $extended);
+ $str = re_dq_disambiguate($first, $last);
+ $kid = $kid->sibling;
+ }
+ return $str, 1;
+ }
+
+ return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
+ return ($self->deparse($kid, $cx), 0);
+}
+
+sub pp_regcomp {
+ my ($self, $op, $cx) = @_;
+ return (($self->regcomp($op, $cx, 0))[0]);
+}
+
+# osmic acid -- see osmium tetroxide
+
+my %matchwords;
+map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
+ 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+
+sub matchop {
+ my $self = shift;
+ my($op, $cx, $name, $delim) = @_;
+ my $kid = $op->first;
+ my ($binop, $var, $re) = ("", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $quote = 1;
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ } else {
+ $re = re_uninterp(escape_str(re_unback($op->precomp)));
+ }
+ } elsif ($kid->name ne 'regcomp') {
+ carp("found ".$kid->name." where regcomp expected");
+ } else {
+ ($re, $quote) = $self->regcomp($kid, 21, $extended);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->pmflags & PMf_CONTINUE;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $op->pmflags & PMf_EXTENDED;
+ $flags = $matchwords{$flags} if $matchwords{$flags};
+ if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
+ $re =~ s/\?/\\?/g;
+ $re = "?$re?";
+ } elsif ($quote) {
+ $re = single_delim($name, $delim, $re);
+ }
+ $re = $re . $flags if $quote;
+ if ($binop) {
+ return $self->maybe_parens("$var =~ $re", $cx, 20);
+ } else {
+ return $re;
+ }
+}
+
+sub pp_match { matchop(@_, "m", "/") }
+sub pp_pushre { matchop(@_, "m", "/") }
+sub pp_qr { matchop(@_, "qr", "") }
+
+sub pp_split {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($kid, @exprs, $ary, $expr);
+ $kid = $op->first;
+
+ # For our kid (an OP_PUSHRE), pmreplroot is never actually the
+ # root of a replacement; it's either empty, or abused to point to
+ # the GV for an array we split into (an optimization to save
+ # assignment overhead). Depending on whether we're using ithreads,
+ # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
+ # figures out for us which it is.
+ my $replroot = $kid->pmreplroot;
+ my $gv = 0;
+ if (ref($replroot) eq "B::GV") {
+ $gv = $replroot;
+ } elsif (!ref($replroot) and $replroot > 0) {
+ $gv = $self->padval($replroot);
+ }
+ $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+
+ # handle special case of split(), and split(' ') that compiles to /\s+/
+ # Under 5.10, the reflags may be undef if the split regexp isn't a constant
+ $kid = $op->first;
+ if ( $kid->flags & OPf_SPECIAL
+ and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
+ : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
+ $exprs[0] = "' '";
+ }
+
+ $expr = "split(" . join(", ", @exprs) . ")";
+ if ($ary) {
+ return $self->maybe_parens("$ary = $expr", $cx, 7);
+ } else {
+ return $expr;
+ }
+}
+
+# oxime -- any of various compounds obtained chiefly by the action of
+# hydroxylamine on aldehydes and ketones and characterized by the
+# bivalent grouping C=NOH [Webster's Tenth]
+
+my %substwords;
+map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
+ 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
+ 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
+ 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
+
+sub pp_subst {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ my($binop, $var, $re, $repl) = ("", "", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $flags = "";
+ if (null($op->pmreplroot)) {
+ $repl = $self->dq($kid);
+ $kid = $kid->sibling;
+ } else {
+ $repl = $op->pmreplroot->first; # skip substcont
+ while ($repl->name eq "entereval") {
+ $repl = $repl->first;
+ $flags .= "e";
+ }
+ if ($op->pmflags & PMf_EVAL) {
+ $repl = $self->deparse($repl->first, 0);
+ } else {
+ $repl = $self->dq($repl);
+ }
+ }
+ my $extended = ($op->pmflags & PMf_EXTENDED);
+ if (null $kid) {
+ my $unbacked = re_unback($op->precomp);
+ if ($extended) {
+ $re = re_uninterp_extended(escape_extended_re($unbacked));
+ }
+ else {
+ $re = re_uninterp(escape_str($unbacked));
+ }
+ } else {
+ ($re) = $self->regcomp($kid, 1, $extended);
+ }
+ $flags .= "e" if $op->pmflags & PMf_EVAL;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $extended;
+ $flags = $substwords{$flags} if $substwords{$flags};
+ if ($binop) {
+ return $self->maybe_parens("$var =~ s"
+ . double_delim($re, $repl) . $flags,
+ $cx, 20);
+ } else {
+ return "s". double_delim($re, $repl) . $flags;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+B::Deparse - Perl compiler backend to produce perl code
+
+=head1 SYNOPSIS
+
+B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
+ [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
+
+=head1 DESCRIPTION
+
+B::Deparse is a backend module for the Perl compiler that generates
+perl source code, based on the internal compiled structure that perl
+itself creates after parsing a program. The output of B::Deparse won't
+be exactly the same as the original source, since perl doesn't keep
+track of comments or whitespace, and there isn't a one-to-one
+correspondence between perl's syntactical constructions and their
+compiled form, but it will often be close. When you use the B<-p>
+option, the output also includes parentheses even when they are not
+required by precedence, which can make it easy to see if perl is
+parsing your expressions the way you intended.
+
+While B::Deparse goes to some lengths to try to figure out what your
+original program was doing, some parts of the language can still trip
+it up; it still fails even on some parts of Perl's own test suite. If
+you encounter a failure other than the most common ones described in
+the BUGS section below, you can help contribute to B::Deparse's
+ongoing development by submitting a bug report with a small
+example.
+
+=head1 OPTIONS
+
+As with all compiler backend options, these must follow directly after
+the '-MO=Deparse', separated by a comma but not any white space.
+
+=over 4
+
+=item B<-d>
+
+Output data values (when they appear as constants) using Data::Dumper.
+Without this option, B::Deparse will use some simple routines of its
+own for the same purpose. Currently, Data::Dumper is better for some
+kinds of data (such as complex structures with sharing and
+self-reference) while the built-in routines are better for others
+(such as odd floating-point values).
+
+=item B<-f>I<FILE>
+
+Normally, B::Deparse deparses the main code of a program, and all the subs
+defined in the same file. To include subs defined in other files, pass the
+B<-f> option with the filename. You can pass the B<-f> option several times, to
+include more than one secondary file. (Most of the time you don't want to
+use it at all.) You can also use this option to include subs which are
+defined in the scope of a B<#line> directive with two parameters.
+
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
+=item B<-p>
+
+Print extra parentheses. Without this option, B::Deparse includes
+parentheses in its output only when they are needed, based on the
+structure of your program. With B<-p>, it uses parentheses (almost)
+whenever they would be legal. This can be useful if you are used to
+LISP, or if you want to see how perl parses your input. If you say
+
+ if ($var & 0x7f == 65) {print "Gimme an A!"}
+ print ($which ? $a : $b), "\n";
+ $name = $ENV{USER} or "Bob";
+
+C<B::Deparse,-p> will print
+
+ if (($var & 0)) {
+ print('Gimme an A!')
+ };
+ (print(($which ? $a : $b)), '???');
+ (($name = $ENV{'USER'}) or '???')
+
+which probably isn't what you intended (the C<'???'> is a sign that
+perl optimized away a constant value).
+
+=item B<-P>
+
+Disable prototype checking. With this option, all function calls are
+deparsed as if no prototype was defined for them. In other words,
+
+ perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
+
+will print
+
+ sub foo (\@) {
+ 1;
+ }
+ &foo(\@x);
+
+making clear how the parameters are actually passed to C<foo>.
+
+=item B<-q>
+
+Expand double-quoted strings into the corresponding combinations of
+concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
+instance, print
+
+ print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
+
+as
+
+ print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
+ . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
+
+Note that the expanded form represents the way perl handles such
+constructions internally -- this option actually turns off the reverse
+translation that B::Deparse usually does. On the other hand, note that
+C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
+of $y into a string before doing the assignment.
+
+=item B<-s>I<LETTERS>
+
+Tweak the style of B::Deparse's output. The letters should follow
+directly after the 's', with no space or punctuation. The following
+options are available:
+
+=over 4
+
+=item B<C>
+
+Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
+
+ if (...) {
+ ...
+ } else {
+ ...
+ }
+
+instead of
+
+ if (...) {
+ ...
+ }
+ else {
+ ...
+ }
+
+The default is not to cuddle.
+
+=item B<i>I<NUMBER>
+
+Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
+
+=item B<T>
+
+Use tabs for each 8 columns of indent. The default is to use only spaces.
+For instance, if the style options are B<-si4T>, a line that's indented
+3 times will be preceded by one tab and four spaces; if the options were
+B<-si8T>, the same line would be preceded by three tabs.
+
+=item B<v>I<STRING>B<.>
+
+Print I<STRING> for the value of a constant that can't be determined
+because it was optimized away (mnemonic: this happens when a constant
+is used in B<v>oid context). The end of the string is marked by a period.
+The string should be a valid perl expression, generally a constant.
+Note that unless it's a number, it probably needs to be quoted, and on
+a command line quotes need to be protected from the shell. Some
+conventional values include 0, 1, 42, '', 'foo', and
+'Useless use of constant omitted' (which may need to be
+B<-sv"'Useless use of constant omitted'.">
+or something similar depending on your shell). The default is '???'.
+If you're using B::Deparse on a module or other file that's require'd,
+you shouldn't use a value that evaluates to false, since the customary
+true constant at the end of a module will be in void context when the
+file is compiled as a main program.
+
+=back
+
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+ for ($i = 0; $i < 10; ++$i) {
+ print $i;
+ }
+
+turns into
+
+ $i = 0;
+ while ($i < 10) {
+ print $i;
+ } continue {
+ ++$i
+ }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 5, C<use> declarations will be translated into
+C<BEGIN> blocks containing calls to C<require> and C<import>; for
+instance,
+
+ use strict 'refs';
+
+turns into
+
+ sub BEGIN {
+ require strict;
+ do {
+ 'strict'->import('refs')
+ };
+ }
+
+If I<LEVEL> is at least 7, C<if> statements will be translated into
+equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+ print 'hi' if $nice;
+ if ($nice) {
+ print 'hi';
+ }
+ if ($nice) {
+ print 'hi';
+ } else {
+ print 'bye';
+ }
+
+turns into
+
+ $nice and print 'hi';
+ $nice and do { print 'hi' };
+ $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
+=back
+
+=head1 USING B::Deparse AS A MODULE
+
+=head2 Synopsis
+
+ use B::Deparse;
+ $deparse = B::Deparse->new("-p", "-sC");
+ $body = $deparse->coderef2text(\&func);
+ eval "sub func $body"; # the inverse operation
+
+=head2 Description
+
+B::Deparse can also be used on a sub-by-sub basis from other perl
+programs.
+
+=head2 new
+
+ $deparse = B::Deparse->new(OPTIONS)
+
+Create an object to store the state of a deparsing operation and any
+options. The options are the same as those that can be given on the
+command line (see L</OPTIONS>); options that are separated by commas
+after B<-MO=Deparse> should be given as separate strings.
+
+=head2 ambient_pragmas
+
+ $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
+
+The compilation of a subroutine can be affected by a few compiler
+directives, B<pragmas>. These are:
+
+=over 4
+
+=item *
+
+use strict;
+
+=item *
+
+use warnings;
+
+=item *
+
+Assigning to the special variable $[
+
+=item *
+
+use integer;
+
+=item *
+
+use bytes;
+
+=item *
+
+use utf8;
+
+=item *
+
+use re;
+
+=back
+
+Ordinarily, if you use B::Deparse on a subroutine which has
+been compiled in the presence of one or more of these pragmas,
+the output will include statements to turn on the appropriate
+directives. So if you then compile the code returned by coderef2text,
+it will behave the same way as the subroutine which you deparsed.
+
+However, you may know that you intend to use the results in a
+particular context, where some pragmas are already in scope. In
+this case, you use the B<ambient_pragmas> method to describe the
+assumptions you wish to make.
+
+Not all of the options currently have any useful effect. See
+L</BUGS> for more details.
+
+The parameters it accepts are:
+
+=over 4
+
+=item strict
+
+Takes a string, possibly containing several values separated
+by whitespace. The special values "all" and "none" mean what you'd
+expect.
+
+ $deparse->ambient_pragmas(strict => 'subs refs');
+
+=item $[
+
+Takes a number, the value of the array base $[.
+
+=item bytes
+
+=item utf8
+
+=item integer
+
+If the value is true, then the appropriate pragma is assumed to
+be in the ambient scope, otherwise not.
+
+=item re
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special. It's also permissible
+to pass an array reference here.
+
+ $deparser->ambient_pragmas(re => 'eval');
+
+
+=item warnings
+
+Takes a string, possibly containing a whitespace-separated list of
+values. The values "all" and "none" are special, again. It's also
+permissible to pass an array reference here.
+
+ $deparser->ambient_pragmas(warnings => [qw[void io]]);
+
+If one of the values is the string "FATAL", then all the warnings
+in that list will be considered fatal, just as with the B<warnings>
+pragma itself. Should you need to specify that some warnings are
+fatal, and others are merely enabled, you can pass the B<warnings>
+parameter twice:
+
+ $deparser->ambient_pragmas(
+ warnings => 'all',
+ warnings => [FATAL => qw/void io/],
+ );
+
+See L<perllexwarn> for more information about lexical warnings.
+
+=item hint_bits
+
+=item warning_bits
+
+These two parameters are used to specify the ambient pragmas in
+the format used by the special variables $^H and ${^WARNING_BITS}.
+
+They exist principally so that you can write code like:
+
+ { my ($hint_bits, $warning_bits);
+ BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ $deparser->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ ); }
+
+which specifies that the ambient pragmas are exactly those which
+are in scope at the point of calling.
+
+=item %^H
+
+This parameter is used to specify the ambient pragmas which are
+stored in the special hash %^H.
+
+=back
+
+=head2 coderef2text
+
+ $body = $deparse->coderef2text(\&func)
+ $body = $deparse->coderef2text(sub ($$) { ... })
+
+Return source code for the body of a subroutine (a block, optionally
+preceded by a prototype in parens), given a reference to the
+sub. Because a subroutine can have no names, or more than one name,
+this method doesn't return a complete subroutine definition -- if you
+want to eval the result, you should prepend "sub subname ", or "sub "
+for an anonymous function constructor. Unless the sub was defined in
+the main:: package, the code will include a package declaration.
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+The only pragmas to be completely supported are: C<use warnings>,
+C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
+behaves like a pragma, is also supported.)
+
+Excepting those listed above, we're currently unable to guarantee that
+B::Deparse will produce a pragma at the correct point in the program.
+(Specifically, pragmas at the beginning of a block often appear right
+before the start of the block instead.)
+Since the effects of pragmas are often lexically scoped, this can mean
+that the pragma holds sway over a different portion of the program
+than in the input file.
+
+=item *
+
+In fact, the above is a specific instance of a more general problem:
+we can't guarantee to produce BEGIN blocks or C<use> declarations in
+exactly the right place. So if you use a module which affects compilation
+(such as by over-riding keywords, overloading constants or whatever)
+then the output code might not work as intended.
+
+This is the most serious outstanding problem, and will require some help
+from the Perl core to fix.
+
+=item *
+
+If a keyword is over-ridden, and your program explicitly calls
+the built-in version by using CORE::keyword, the output of B::Deparse
+will not reflect this. If you run the resulting code, it will call
+the over-ridden version rather than the built-in one. (Maybe there
+should be an option to B<always> print keyword calls as C<CORE::name>.)
+
+=item *
+
+Some constants don't print correctly either with or without B<-d>.
+For instance, neither B::Deparse nor Data::Dumper know how to print
+dual-valued scalars correctly, as in:
+
+ use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
+
+ use constant H => { "#" => 1 }; H->{"#"};
+
+=item *
+
+An input file that uses source filtering probably won't be deparsed into
+runnable code, because it will still include the B<use> declaration
+for the source filtering module, even though the code that is
+produced is already ordinary Perl which shouldn't be filtered again.
+
+=item *
+
+Optimised away statements are rendered as '???'. This includes statements that
+have a compile-time side-effect, such as the obscure
+
+ my $x if 0;
+
+which is not, consequently, deparsed correctly.
+
+ foreach my $i (@_) { 0 }
+ =>
+ foreach my $i (@_) { '???' }
+
+=item *
+
+Lexical (my) variables declared in scopes external to a subroutine
+appear in code2ref output text as package variables. This is a tricky
+problem, as perl has no native facility for refering to a lexical variable
+defined within a different scope, although L<PadWalker> is a good start.
+
+=item *
+
+There are probably many more bugs on non-ASCII platforms (EBCDIC).
+
+=back
+
+=head1 AUTHOR
+
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
+by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
+Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
+Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
+Garcia-Suarez.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm
new file mode 100644
index 00000000000..b039215ad75
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Lint.pm
@@ -0,0 +1,792 @@
+package B::Lint;
+
+our $VERSION = '1.11_01'; ## no critic
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program F<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each such
+argument (apart from the special B<all> and B<none> options) is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> (turning off that check). Before processing the check
+arguments, a standard list of checks is turned on. Later options
+override earlier ones. Available options are:
+
+=over 8
+
+=item B<magic-diamond>
+
+Produces a warning whenever the magic C<E<lt>E<gt>> readline is
+used. Internally it uses perl's two-argument open which itself treats
+filenames with special characters specially. This could allow
+interestingly named files to have unexpected effects when reading.
+
+ % touch 'rm *|'
+ % perl -pe 1
+
+The above creates a file named C<rm *|>. When perl opens it with
+C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
+makes C<E<lt>E<gt>> dangerous to use carelessly.
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+ $foo = length(@bar);
+ $foo = @bar;
+
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+ $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+ /foo/;
+
+and B<implicit-write> will warn about these:
+
+ s/foo/bar/;
+
+Both B<implicit-read> and B<implicit-write> warn about this:
+
+ for (@a) { ... }
+
+=item B<bare-subs>
+
+This option warns whenever a bareword is implicitly quoted, but is also
+the name of a subroutine in the current package. Typical mistakes that it will
+trap are:
+
+ use constant foo => 'bar';
+ @a = ( foo => 1 );
+ $b{foo} = 2;
+
+Neither of these will do what a naive user would expect.
+
+=item B<dollar-underscore>
+
+This option warns whenever C<$_> is used either explicitly anywhere or
+as the implicit argument of a B<print> statement.
+
+=item B<private-names>
+
+This option warns on each use of any variable, subroutine or
+method name that lives in a non-current package but begins with
+an underscore ("_"). Warnings aren't issued for the special case
+of the single character name "_" by itself (e.g. C<$_> and C<@_>).
+
+=item B<undefined-subs>
+
+This option warns whenever an undefined subroutine is invoked.
+This option will only catch explicitly invoked subroutines such
+as C<foo()> and not indirect invocations such as C<&$subref()>
+or C<$obj-E<gt>meth()>. Note that some programs or modules delay
+definition of subs until runtime by means of the AUTOLOAD
+mechanism.
+
+=item B<regexp-variables>
+
+This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
+is used. Any occurrence of any of these variables in your
+program can slow your whole program down. See L<perlre> for
+details.
+
+=item B<all>
+
+Turn all warnings on.
+
+=item B<none>
+
+Turn all warnings off.
+
+=back
+
+=head1 NON LINT-CHECK OPTIONS
+
+=over 8
+
+=item B<-u Package>
+
+Normally, Lint only checks the main code of the program together
+with all subs defined in package main. The B<-u> option lets you
+include other package names whose subs are then checked by Lint.
+
+=back
+
+=head1 EXTENDING LINT
+
+Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
+to find available plugins. Plugins are expected but not required to
+inform Lint of which checks they are adding.
+
+The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
+adds the list of C<@new_checks> to the list of valid checks. If your
+module wasn't loaded by L<Module::Pluggable> then your class name is
+added to the list of plugins.
+
+You must create a C<match( \%checks )> method in your plugin class or one
+of its parents. It will be called on every op as a regular method call
+with a hash ref of checks as its parameter.
+
+The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
+the current filename and line number.
+
+ package Sample;
+ use B::Lint;
+ B::Lint->register_plugin( Sample => [ 'good_taste' ] );
+
+ sub match {
+ my ( $op, $checks_href ) = shift @_;
+ if ( $checks_href->{good_taste} ) {
+ ...
+ }
+ }
+
+=head1 TODO
+
+=over
+
+=item while(<FH>) stomps $_
+
+=item strict oo
+
+=item unchecked system calls
+
+=item more tests, validate against older perls
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=head1 ACKNOWLEDGEMENTS
+
+Sebastien Aperghis-Tramoni - bug fixes
+
+=cut
+
+use strict;
+use B qw( walkoptree_slow
+ main_root main_cv walksymtable parents
+ OPpOUR_INTRO
+ OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK );
+use Carp 'carp';
+
+# The current M::P doesn't know about .pmc files.
+use Module::Pluggable ( require => 1 );
+
+use List::Util 'first';
+## no critic Prototypes
+sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
+
+BEGIN {
+
+ # Import or create some constants from B. B doesn't provide
+ # everything I need so some things like OPpCONST_BARE are defined
+ # here.
+ for my $sym ( qw( begin_av check_av init_av end_av ),
+ [ 'OPpCONST_BARE' => 64 ] )
+ {
+ my $val;
+ ( $sym, $val ) = @$sym if ref $sym;
+
+ if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
+ B->import($sym);
+ }
+ else {
+ require constant;
+ constant->import( $sym => $val );
+ }
+ }
+}
+
+my $file = "unknown"; # shadows current filename
+my $line = 0; # shadows current line number
+my $curstash = "main"; # shadows current stash
+my $curcv; # shadows current B::CV for pad lookups
+
+sub file {$file}
+sub line {$line}
+sub curstash {$curstash}
+sub curcv {$curcv}
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+
+map( $implies_ok_context{$_}++,
+ qw(scalar av2arylen aelem aslice helem hslice
+ keys values hslice defined undef delete) );
+
+# Lint checks turned on by default
+my @default_checks
+ = qw(context magic_diamond undefined_subs regexp_variables);
+
+my %valid_check;
+
+# All valid checks
+for my $check (
+ qw(context implicit_read implicit_write dollar_underscore
+ private_names bare_subs undefined_subs regexp_variables
+ magic_diamond )
+ )
+{
+ $valid_check{$check} = __PACKAGE__;
+}
+
+# Debugging options
+my ($debug_op);
+
+my %done_cv; # used to mark which subs have already been linted
+my @extra_packages; # Lint checks mainline code and all subs which are
+ # in main:: or in one of these packages.
+
+sub warning {
+ my $format = ( @_ < 2 ) ? "%s" : shift @_;
+ warn sprintf( "$format at %s line %d\n", @_, $file, $line );
+ return undef; ## no critic undef
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+ my $op = shift @_;
+ my $flags = $op->flags;
+ if ( $flags & OPf_WANT ) {
+ return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
+ }
+ return undef; ## no critic undef
+}
+
+my @plugins = __PACKAGE__->plugins;
+
+sub inside_grepmap {
+
+ # A boolean function to be used while inside a B::walkoptree_slow
+ # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep
+ # { EXPR } ...>, this returns true.
+ return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
+}
+
+sub inside_foreach_modifier {
+
+ # TODO: use any()
+
+ # A boolean function to be used while inside a B::walkoptree_slow
+ # call. If we are in the EXPR part of C<EXPR foreach ...> this
+ # returns true.
+ for my $ancestor ( @{ parents() } ) {
+ next unless $ancestor->name eq 'leaveloop';
+
+ my $first = $ancestor->first;
+ next unless $first->name eq 'enteriter';
+
+ next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+ return 1;
+ }
+ return 0;
+}
+
+for (
+ [qw[ B::PADOP::gv_harder gv padix]],
+ [qw[ B::SVOP::sv_harder sv targ]],
+ [qw[ B::SVOP::gv_harder gv padix]]
+ )
+{
+
+ # I'm generating some functions here because they're mostly
+ # similar. It's all for compatibility with threaded
+ # perl. Perhaps... this code should inspect $Config{usethreads}
+ # and generate a *specific* function. I'm leaving it generic for
+ # the moment.
+ #
+ # In threaded perl SVs and GVs aren't used directly in the optrees
+ # like they are in non-threaded perls. The ops that would use a SV
+ # or GV keep an index into the subroutine's scratchpad. I'm
+ # currently ignoring $cv->DEPTH and that might be at my peril.
+
+ my ( $subname, $attr, $pad_attr ) = @$_;
+ my $target = do { ## no critic strict
+ no strict 'refs';
+ \*$subname;
+ };
+ *$target = sub {
+ my ($op) = @_;
+
+ my $elt;
+ if ( not $op->isa('B::PADOP') ) {
+ $elt = $op->$attr;
+ }
+ return $elt if eval { $elt->isa('B::SV') };
+
+ my $ix = $op->$pad_attr;
+ my @entire_pad = $curcv->PADLIST->ARRAY;
+ my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
+ ($elt) = first {
+ eval { $_->isa('B::SV') } ? $_ : ();
+ }
+ @elts[ 0, reverse 1 .. $#elts ];
+ return $elt;
+ };
+}
+
+sub B::OP::lint {
+ my ($op) = @_;
+
+ # This is a fallback ->lint for all the ops where I haven't
+ # defined something more specific. Nothing happens here.
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::COP::lint {
+ my ($op) = @_;
+
+ # nextstate ops sit between statements. Whenever I see one I
+ # update the current info on file, line, and stash. This code also
+ # updates it when it sees a dbstate or setstate op. I have no idea
+ # what those are but having seen them mentioned together in other
+ # parts of the perl I think they're kind of equivalent.
+ if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) {
+ $file = $op->file;
+ $line = $op->line;
+ $curstash = $op->stash->NAME;
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::UNOP::lint {
+ my ($op) = @_;
+
+ my $opname = $op->name;
+
+CONTEXT: {
+
+ # Check arrays and hashes in scalar or void context where
+ # scalar() hasn't been used.
+
+ next
+ unless $check{context}
+ and $opname =~ m/\Arv2[ah]v\z/xms
+ and not gimme($op);
+
+ my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ];
+ my $pname = $parent->name;
+
+ next if $implies_ok_context{$pname};
+
+ # Three special cases to deal with: "foreach (@foo)", "delete
+ # $a{$b}", and "exists $a{$b}" null out the parent so we have to
+ # check for a parent of pp_null and a grandparent of
+ # pp_enteriter, pp_delete, pp_exists
+
+ next
+ if $pname eq "null"
+ and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms;
+
+ # our( @bar ); would also trigger this error so I exclude
+ # that.
+ next
+ if $op->private & OPpOUR_INTRO
+ and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
+
+ warning 'Implicit scalar context for %s in %s',
+ $opname eq "rv2av" ? "array" : "hash", $parent->desc;
+ }
+
+PRIVATE_NAMES: {
+
+ # Looks for calls to methods with names that begin with _ and
+ # that aren't visible within the current package. Maybe this
+ # should look at @ISA.
+ next
+ unless $check{private_names}
+ and $opname =~ m/\Amethod/xms;
+
+ my $methop = $op->first;
+ next unless $methop->name eq "const";
+
+ my $method = $methop->sv_harder->PV;
+ next
+ unless $method =~ m/\A_/xms
+ and not defined &{"$curstash\::$method"};
+
+ warning q[Illegal reference to private method name '%s'], $method;
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::PMOP::lint {
+ my ($op) = @_;
+
+IMPLICIT_READ: {
+
+ # Look for /.../ that doesn't use =~ to bind to something.
+ next
+ unless $check{implicit_read}
+ and $op->name eq "match"
+ and not( $op->flags & OPf_STACKED
+ or inside_grepmap() );
+ warning 'Implicit match on $_';
+ }
+
+IMPLICIT_WRITE: {
+
+ # Look for s/.../.../ that doesn't use =~ to bind to
+ # something.
+ next
+ unless $check{implicit_write}
+ and $op->name eq "subst"
+ and not $op->flags & OPf_STACKED;
+ warning 'Implicit substitution on $_';
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::LOOP::lint {
+ my ($op) = @_;
+
+IMPLICIT_FOO: {
+
+ # Look for C<for ( ... )>.
+ next
+ unless ( $check{implicit_read} or $check{implicit_write} )
+ and $op->name eq "enteriter";
+
+ my $last = $op->last;
+ next
+ unless $last->name eq "gv"
+ and $last->gv_harder->NAME eq "_"
+ and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+ warning 'Implicit use of $_ in foreach';
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+# In threaded vs non-threaded perls you'll find that threaded perls
+# use PADOP in place of SVOPs so they can do lookups into the
+# scratchpad to find things. I suppose this is so a optree can be
+# shared between threads and all symbol table muckery will just get
+# written to a scratchpad.
+*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
+
+sub B::SVOP::lint {
+ my ($op) = @_;
+
+MAGIC_DIAMOND: {
+ next
+ unless $check{magic_diamond}
+ and parents()->[0]->name eq 'readline'
+ and $op->gv_harder->NAME eq 'ARGV';
+
+ warning 'Use of <>';
+ }
+
+BARE_SUBS: {
+ next
+ unless $check{bare_subs}
+ and $op->name eq 'const'
+ and $op->private & OPpCONST_BARE;
+
+ my $sv = $op->sv_harder;
+ next unless $sv->FLAGS & SVf_POK;
+
+ my $sub = $sv->PV;
+ my $subname = "$curstash\::$sub";
+
+ # I want to skip over things that were declared with the
+ # constant pragma. Well... sometimes. Hmm. I want to ignore
+ # C<<use constant FOO => ...>> but warn on C<<FOO => ...>>
+ # later. The former is typical declaration syntax and the
+ # latter would be an error.
+ #
+ # Skipping over both could be handled by looking if
+ # $constant::declared{$subname} is true.
+
+ # Check that it's a function.
+ next
+ unless exists &{"$curstash\::$sub"};
+
+ warning q[Bare sub name '%s' interpreted as string], $sub;
+ }
+
+PRIVATE_NAMES: {
+ next unless $check{private_names};
+
+ my $opname = $op->name;
+ if ( $opname =~ m/\Agv(?:sv)?\z/xms ) {
+
+ # Looks for uses of variables and stuff that are named
+ # private and we're not in the same package.
+ my $gv = $op->gv_harder;
+ my $name = $gv->NAME;
+ next
+ unless $name =~ m/\A_./xms
+ and $gv->STASH->NAME ne $curstash;
+
+ warning q[Illegal reference to private name '%s'], $name;
+ }
+ elsif ( $opname eq "method_named" ) {
+ my $method = $op->sv_harder->PV;
+ next unless $method =~ m/\A_./xms;
+
+ warning q[Illegal reference to private method name '%s'], $method;
+ }
+ }
+
+DOLLAR_UNDERSCORE: {
+
+ # Warn on uses of $_ with a few exceptions. I'm not warning on
+ # $_ inside grep, map, or statement modifer foreach because
+ # they localize $_ and it'd be impossible to use these
+ # features without getting warnings.
+
+ next
+ unless $check{dollar_underscore}
+ and $op->name eq "gvsv"
+ and $op->gv_harder->NAME eq "_"
+ and not( inside_grepmap
+ or inside_foreach_modifier );
+
+ warning 'Use of $_';
+ }
+
+REGEXP_VARIABLES: {
+
+ # Look for any uses of $`, $&, or $'.
+ next
+ unless $check{regexp_variables}
+ and $op->name eq "gvsv";
+
+ my $name = $op->gv_harder->NAME;
+ next unless $name =~ m/\A[\&\'\`]\z/xms;
+
+ warning 'Use of regexp variable $%s', $name;
+ }
+
+UNDEFINED_SUBS: {
+
+ # Look for calls to functions that either don't exist or don't
+ # have a definition.
+ next
+ unless $check{undefined_subs}
+ and $op->name eq "gv"
+ and $op->next->name eq "entersub";
+
+ my $gv = $op->gv_harder;
+ my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+
+ no strict 'refs'; ## no critic strict
+ if ( not exists &$subname ) {
+ $subname =~ s/\Amain:://;
+ warning q[Nonexistant subroutine '%s' called], $subname;
+ }
+ elsif ( not defined &$subname ) {
+ $subname =~ s/\A\&?main:://;
+ warning q[Undefined subroutine '%s' called], $subname;
+ }
+ }
+
+ # Call all registered plugins
+ my $m;
+ $m = $_->can('match'), $op->$m( \%check ) for @plugins;
+ return;
+}
+
+sub B::GV::lintcv {
+
+ # Example: B::svref_2object( \ *A::Glob )->lintcv
+
+ my $gv = shift @_;
+ my $cv = $gv->CV;
+ return unless $cv->can('lintcv');
+ $cv->lintcv;
+ return;
+}
+
+sub B::CV::lintcv {
+
+ # Example: B::svref_2object( \ &foo )->lintcv
+
+ # Write to the *global* $
+ $curcv = shift @_;
+
+ #warn sprintf("lintcv: %s::%s (done=%d)\n",
+ # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug
+ return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++;
+ my $root = $curcv->ROOT;
+
+ #warn " root = $root (0x$$root)\n";#debug
+ walkoptree_slow( $root, "lint" ) if $$root;
+ return;
+}
+
+sub do_lint {
+ my %search_pack;
+
+ # Copy to the global $curcv for use in pad lookups.
+ $curcv = main_cv;
+ walkoptree_slow( main_root, "lint" ) if ${ main_root() };
+
+ # Do all the miscellaneous non-sub blocks.
+ for my $av ( begin_av, init_av, check_av, end_av ) {
+ next unless eval { $av->isa('B::AV') };
+ for my $cv ( $av->ARRAY ) {
+ next unless ref($cv) and $cv->FILE eq $0;
+ $cv->lintcv;
+ }
+ }
+
+ walksymtable(
+ \%main::,
+ sub {
+ if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
+ },
+ sub {1}
+ );
+ return;
+}
+
+sub compile {
+ my @options = @_;
+
+ # Turn on default lint checks
+ for my $opt (@default_checks) {
+ $check{$opt} = 1;
+ }
+
+OPTION:
+ while ( my $option = shift @options ) {
+ my ( $opt, $arg );
+ unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) {
+ unshift @options, $option;
+ last OPTION;
+ }
+
+ if ( $opt eq "-" && $arg eq "-" ) {
+ shift @options;
+ last OPTION;
+ }
+ elsif ( $opt eq "D" ) {
+ $arg ||= shift @options;
+ foreach my $arg ( split //, $arg ) {
+ if ( $arg eq "o" ) {
+ B->debug(1);
+ }
+ elsif ( $arg eq "O" ) {
+ $debug_op = 1;
+ }
+ }
+ }
+ elsif ( $opt eq "u" ) {
+ $arg ||= shift @options;
+ push @extra_packages, $arg;
+ }
+ }
+
+ foreach my $opt ( @default_checks, @options ) {
+ $opt =~ tr/-/_/;
+ if ( $opt eq "all" ) {
+ %check = %valid_check;
+ }
+ elsif ( $opt eq "none" ) {
+ %check = ();
+ }
+ else {
+ if ( $opt =~ s/\Ano_//xms ) {
+ $check{$opt} = 0;
+ }
+ else {
+ $check{$opt} = 1;
+ }
+ carp "No such check: $opt"
+ unless defined $valid_check{$opt};
+ }
+ }
+
+ # Remaining arguments are things to check. So why aren't I
+ # capturing them or something? I don't know.
+
+ return \&do_lint;
+}
+
+sub register_plugin {
+ my ( undef, $plugin, $new_checks ) = @_;
+
+ # Allow the user to be lazy and not give us a name.
+ $plugin = caller unless defined $plugin;
+
+ # Register the plugin's named checks, if any.
+ for my $check ( eval {@$new_checks} ) {
+ if ( not defined $check ) {
+ carp 'Undefined value in checks.';
+ next;
+ }
+ if ( exists $valid_check{$check} ) {
+ carp
+ "$check is already registered as a $valid_check{$check} feature.";
+ next;
+ }
+
+ $valid_check{$check} = $plugin;
+ }
+
+ # Register a non-Module::Pluggable loaded module. @plugins already
+ # contains whatever M::P found on disk. The user might load a
+ # plugin manually from some arbitrary namespace and ask for it to
+ # be registered.
+ if ( not any { $_ eq $plugin } @plugins ) {
+ push @plugins, $plugin;
+ }
+
+ return;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
new file mode 100644
index 00000000000..5929bb6d428
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
@@ -0,0 +1,67 @@
+package B::Lint::Debug;
+
+our $VERSION = '0.01';
+
+=head1 NAME
+
+B::Lint::Debug - Adds debugging stringification to B::
+
+=head1 DESCRIPTION
+
+This module injects stringification to a B::OP*/B::SPECIAL. This
+should not be loaded unless you're debugging.
+
+=cut
+
+package B::SPECIAL;
+use overload '""' => sub {
+ my $self = shift @_;
+ "SPECIAL($$self)";
+};
+
+package B::OP;
+use overload '""' => sub {
+ my $self = shift @_;
+ my $class = ref $self;
+ $class =~ s/\AB:://xms;
+ my $name = $self->name;
+ "$class($name)";
+};
+
+package B::SVOP;
+use overload '""' => sub {
+ my $self = shift @_;
+ my $class = ref $self;
+ $class =~ s/\AB:://xms;
+ my $name = $self->name;
+ "$class($name," . $self->sv . "," . $self->gv . ")";
+};
+
+package B::SPECIAL;
+sub DESTROY { }
+our $AUTOLOAD;
+
+sub AUTOLOAD {
+ my $cx = 0;
+ print "AUTOLOAD $AUTOLOAD\n";
+
+ package DB;
+ while ( my @stuff = caller $cx ) {
+
+ print "$cx: [@DB::args] [@stuff]\n";
+ if ( ref $DB::args[0] ) {
+ if ( $DB::args[0]->can('padix') ) {
+ print " PADIX: " . $DB::args[0]->padix . "\n";
+ }
+ if ( $DB::args[0]->can('targ') ) {
+ print " TARG: " . $DB::args[0]->targ . "\n";
+ for ( B::Lint::cv()->PADLIST->ARRAY ) {
+ print +( $_->ARRAY )[ $DB::args[0]->targ ] . "\n";
+ }
+ }
+ }
+ ++$cx;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm
new file mode 100644
index 00000000000..3b261a337df
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Showlex.pm
@@ -0,0 +1,205 @@
+package B::Showlex;
+
+our $VERSION = '1.02';
+
+use strict;
+use B qw(svref_2object comppadlist class);
+use B::Terse ();
+use B::Concise ();
+
+#
+# Invoke as
+# perl -MO=Showlex,foo bar.pl
+# to see the names of lexical variables used by &foo
+# or as
+# perl -MO=Showlex bar.pl
+# to see the names of file scope lexicals used by bar.pl
+#
+
+
+# borrowed from B::Concise
+our $walkHandle = \*STDOUT;
+
+sub walk_output { # updates $walkHandle
+ $walkHandle = B::Concise::walk_output(@_);
+ #print "got $walkHandle";
+ #print $walkHandle "using it";
+ $walkHandle;
+}
+
+sub shownamearray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print $walkHandle "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ my $sv = $els[$i];
+ if (class($sv) ne "SPECIAL") {
+ printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
+ } else {
+ printf $walkHandle "$i: %s\n", $sv->terse;
+ #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
+ }
+ }
+}
+
+sub showvaluearray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print $walkHandle "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ printf $walkHandle "$i: %s\n", $els[$i]->terse;
+ #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
+ }
+}
+
+sub showlex {
+ my ($objname, $namesav, $valsav) = @_;
+ shownamearray("Pad of lexical names for $objname", $namesav);
+ showvaluearray("Pad of lexical values for $objname", $valsav);
+}
+
+my ($newlex, $nosp1); # rendering state vars
+
+sub newlex { # drop-in for showlex
+ my ($objname, $names, $vals) = @_;
+ my @names = $names->ARRAY;
+ my @vals = $vals->ARRAY;
+ my $count = @names;
+ print $walkHandle "$objname Pad has $count entries\n";
+ printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1;
+ for (my $i = 1; $i < $count; $i++) {
+ printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse
+ unless $nosp1 and $names[$i]->terse =~ /SPECIAL/;
+ }
+}
+
+sub showlex_obj {
+ my ($objname, $obj) = @_;
+ $objname =~ s/^&main::/&/;
+ showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
+ newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
+}
+
+sub showlex_main {
+ showlex("comppadlist", comppadlist->ARRAY) if !$newlex;
+ newlex ("main", comppadlist->ARRAY) if $newlex;
+}
+
+sub compile {
+ my @options = grep(/^-/, @_);
+ my @args = grep(!/^-/, @_);
+ for my $o (@options) {
+ $newlex = 1 if $o eq "-newlex";
+ $nosp1 = 1 if $o eq "-nosp";
+ }
+
+ return \&showlex_main unless @args;
+ return sub {
+ my $objref;
+ foreach my $objname (@args) {
+ next unless $objname; # skip nulls w/o carping
+
+ if (ref $objname) {
+ print $walkHandle "B::Showlex::compile($objname)\n";
+ $objref = $objname;
+ } else {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
+ }
+ showlex_obj($objname, $objref);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Showlex - Show lexical variables used in functions or files
+
+=head1 SYNOPSIS
+
+ perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl
+
+=head1 DESCRIPTION
+
+When a comma-separated list of subroutine names is given as options, Showlex
+prints the lexical variables used in those subroutines. Otherwise, it prints
+the file-scope lexicals in the file.
+
+=head1 EXAMPLES
+
+Traditional form:
+
+ $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
+ Pad of lexical names for comppadlist has 4 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: PVNV (0x9db0fb0) $i
+ 2: PVNV (0x9db0f38) $j
+ 3: PVNV (0x9db0f50) $k
+ Pad of lexical values for comppadlist has 5 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: NULL (0x9da4234)
+ 2: NULL (0x9db0f2c)
+ 3: NULL (0x9db0f44)
+ 4: NULL (0x9da4264)
+ -e syntax OK
+
+New-style form:
+
+ $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
+ main Pad has 4 entries
+ 0: SPECIAL #1 &PL_sv_undef
+ 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234)
+ 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34)
+ 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
+ -e syntax OK
+
+New form, no specials, outside O framework:
+
+ $ perl -MB::Showlex -e \
+ 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
+ main Pad has 4 entries
+ 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1
+ 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo"
+ 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74)
+
+Note that this example shows the values of the lexicals, whereas the other
+examples did not (as they're compile-time only).
+
+=head2 OPTIONS
+
+The C<-newlex> option produces a more readable C<< name => value >> format,
+and is shown in the second example above.
+
+The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL
+#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm
+your declared lexicals.
+
+=head1 SEE ALSO
+
+C<B::Showlex> can also be used outside of the O framework, as in the third
+example. See C<B::Concise> for a fuller explanation of reasons.
+
+=head1 TODO
+
+Some of the reported info, such as hex addresses, is not particularly
+valuable. Other information would be more useful for the typical
+programmer, such as line-numbers, pad-slot reuses, etc.. Given this,
+-newlex isnt a particularly good flag-name.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/B/Terse.pm b/Master/tlpkg/tlperl/lib/B/Terse.pm
new file mode 100644
index 00000000000..562c58abd83
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Terse.pm
@@ -0,0 +1,102 @@
+package B::Terse;
+
+our $VERSION = '1.05';
+
+use strict;
+use B qw(class @specialsv_name);
+use B::Concise qw(concise_subref set_style_standard);
+use Carp;
+
+sub terse {
+ my ($order, $subref) = @_;
+ set_style_standard("terse");
+ if ($order eq "exec") {
+ concise_subref('exec', $subref);
+ } else {
+ concise_subref('basic', $subref);
+ }
+}
+
+sub compile {
+ my @args = @_;
+ my $order = @args ? shift(@args) : "";
+ $order = "-exec" if $order eq "exec";
+ unshift @args, $order if $order ne "";
+ B::Concise::compile("-terse", @args);
+}
+
+sub indent {
+ my ($level) = @_ ? shift : 0;
+ return " " x $level;
+}
+
+# Don't use this, at least on OPs in subroutines: it has no way of
+# getting to the pad, and will give wrong answers or crash.
+sub B::OP::terse {
+ carp "B::OP::terse is deprecated; use B::Concise instead";
+ B::Concise::b_terse(@_);
+}
+
+sub B::SV::terse {
+ my($sv, $level) = (@_, 0);
+ my %info;
+ B::Concise::concise_sv($sv, \%info);
+ my $s = indent($level)
+ . B::Concise::fmt_line(\%info, $sv,
+ "#svclass~(?((#svaddr))?)~#svval", 0);
+ chomp $s;
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+sub B::NULL::terse {
+ my ($sv, $level) = (@_, 0);
+ my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+sub B::SPECIAL::terse {
+ my ($sv, $level) = (@_, 0);
+ my $s = indent($level)
+ . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
+ print "$s\n" unless defined wantarray;
+ $s;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Terse - Walk Perl syntax tree, printing terse info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Terse[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This version of B::Terse is really just a wrapper that calls B::Concise
+with the B<-terse> option. It is provided for compatibility with old scripts
+(and habits) but using B::Concise directly is now recommended instead.
+
+For compatibility with the old B::Terse, this module also adds a
+method named C<terse> to B::OP and B::SV objects. The B::SV method is
+largely compatible with the old one, though authors of new software
+might be advised to choose a more user-friendly output format. The
+B::OP C<terse> method, however, doesn't work well. Since B::Terse was
+first written, much more information in OPs has migrated to the
+scratchpad datastructure, but the C<terse> interface doesn't have any
+way of getting to the correct pad. As a kludge, the new version will
+always use the pad for the main program, but for OPs in subroutines
+this will give the wrong answer or crash.
+
+=head1 AUTHOR
+
+The original version of B::Terse was written by Malcolm Beattie,
+E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
+McCamant, E<lt>smcc@MIT.EDUE<gt>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/B/Xref.pm b/Master/tlpkg/tlperl/lib/B/Xref.pm
new file mode 100644
index 00000000000..64e677ccb82
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Xref.pm
@@ -0,0 +1,431 @@
+package B::Xref;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+B::Xref - Generates cross reference reports for Perl programs
+
+=head1 SYNOPSIS
+
+perl -MO=Xref[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Xref module is used to generate a cross reference listing of all
+definitions and uses of variables, subroutines and formats in a Perl program.
+It is implemented as a backend for the Perl compiler.
+
+The report generated is in the following format:
+
+ File filename1
+ Subroutine subname1
+ Package package1
+ object1 line numbers
+ object2 line numbers
+ ...
+ Package package2
+ ...
+
+Each B<File> section reports on a single file. Each B<Subroutine> section
+reports on a single subroutine apart from the special cases
+"(definitions)" and "(main)". These report, respectively, on subroutine
+definitions found by the initial symbol table walk and on the main part of
+the program or module external to all subroutines.
+
+The report is then grouped by the B<Package> of each variable,
+subroutine or format with the special case "(lexicals)" meaning
+lexical variables. Each B<object> name (implicitly qualified by its
+containing B<Package>) includes its type character(s) at the beginning
+where possible. Lexical variables are easier to track and even
+included dereferencing information where possible.
+
+The C<line numbers> are a comma separated list of line numbers (some
+preceded by code letters) where that object is used in some way.
+Simple uses aren't preceded by a code letter. Introductions (such as
+where a lexical is first defined with C<my>) are indicated with the
+letter "i". Subroutine and method calls are indicated by the character
+"&". Subroutine definitions are indicated by "s" and format
+definitions by "f".
+
+=head1 OPTIONS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options.
+
+=over 8
+
+=item C<-oFILENAME>
+
+Directs output to C<FILENAME> instead of standard output.
+
+=item C<-r>
+
+Raw output. Instead of producing a human-readable report, outputs a line
+in machine-readable form for each definition/use of a variable/sub/format.
+
+=item C<-d>
+
+Don't output the "(definitions)" sections.
+
+=item C<-D[tO]>
+
+(Internal) debug options, probably only useful if C<-r> included.
+The C<t> option prints the object on the top of the stack as it's
+being tracked. The C<O> option prints each operator as it's being
+processed in the execution order of the program.
+
+=back
+
+=head1 BUGS
+
+Non-lexical variables are quite difficult to track through a program.
+Sometimes the type of a non-lexical variable's use is impossible to
+determine. Introductions of non-lexical non-scalars don't seem to be
+reported properly.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use Config;
+use B qw(peekop class comppadlist main_start svref_2object walksymtable
+ OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
+ );
+
+sub UNKNOWN { ["?", "?", "?"] }
+
+my @pad; # lexicals in current pad
+ # as ["(lexical)", type, name]
+my %done; # keyed by $$op: set when each $op is done
+my $top = UNKNOWN; # shadows top element of stack as
+ # [pack, type, name] (pack can be "(lexical)")
+my $file; # shadows current filename
+my $line; # shadows current line number
+my $subname; # shadows current sub name
+my %table; # Multi-level hash to record all uses etc.
+my @todo = (); # List of CVs that need processing
+
+my %code = (intro => "i", used => "",
+ subdef => "s", subused => "&",
+ formdef => "f", meth => "->");
+
+
+# Options
+my ($debug_op, $debug_top, $nodefs, $raw);
+
+sub process {
+ my ($var, $event) = @_;
+ my ($pack, $type, $name) = @$var;
+ if ($type eq "*") {
+ if ($event eq "used") {
+ return;
+ } elsif ($event eq "subused") {
+ $type = "&";
+ }
+ }
+ $type =~ s/(.)\*$/$1/g;
+ if ($raw) {
+ printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
+ $file, $subname, $line, $pack, $type, $name, $event;
+ } else {
+ # Wheee
+ push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
+ $line);
+ }
+}
+
+sub load_pad {
+ my $padlist = shift;
+ my ($namelistav, $vallistav, @namelist, $ix);
+ @pad = ();
+ return if class($padlist) eq "SPECIAL";
+ ($namelistav,$vallistav) = $padlist->ARRAY;
+ @namelist = $namelistav->ARRAY;
+ for ($ix = 1; $ix < @namelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ next if class($namesv) eq "SPECIAL";
+ my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
+ $pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
+ }
+ if ($Config{useithreads}) {
+ my (@vallist);
+ @vallist = $vallistav->ARRAY;
+ for ($ix = 1; $ix < @vallist; $ix++) {
+ my $valsv = $vallist[$ix];
+ next unless class($valsv) eq "GV";
+ next if class($valsv->STASH) eq 'SPECIAL';
+ # these pad GVs don't have corresponding names, so same @pad
+ # array can be used without collisions
+ $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
+ }
+ }
+}
+
+sub xref {
+ my $start = shift;
+ my $op;
+ for ($op = $start; $$op; $op = $op->next) {
+ last if $done{$$op}++;
+ warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
+ warn peekop($op), "\n" if $debug_op;
+ my $opname = $op->name;
+ if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
+ xref($op->other);
+ } elsif ($opname eq "match" || $opname eq "subst") {
+ xref($op->pmreplstart);
+ } elsif ($opname eq "substcont") {
+ xref($op->other->pmreplstart);
+ $op = $op->other;
+ redo;
+ } elsif ($opname eq "enterloop") {
+ xref($op->redoop);
+ xref($op->nextop);
+ xref($op->lastop);
+ } elsif ($opname eq "subst") {
+ xref($op->pmreplstart);
+ } else {
+ no strict 'refs';
+ my $ppname = "pp_$opname";
+ &$ppname($op) if defined(&$ppname);
+ }
+ }
+}
+
+sub xref_cv {
+ my $cv = shift;
+ my $pack = $cv->GV->STASH->NAME;
+ $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
+ load_pad($cv->PADLIST);
+ xref($cv->START);
+ $subname = "(main)";
+}
+
+sub xref_object {
+ my $cvref = shift;
+ xref_cv(svref_2object($cvref));
+}
+
+sub xref_main {
+ $subname = "(main)";
+ load_pad(comppadlist);
+ xref(main_start);
+ while (@todo) {
+ xref_cv(shift @todo);
+ }
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $file = $op->file;
+ $line = $op->line;
+ $top = UNKNOWN;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ $top = $pad[$op->targ];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+sub deref {
+ my ($op, $var, $as) = @_;
+ $var->[1] = $as . $var->[1];
+ process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
+}
+
+sub pp_rv2cv { deref(shift, $top, "&"); }
+sub pp_rv2hv { deref(shift, $top, "%"); }
+sub pp_rv2sv { deref(shift, $top, "\$"); }
+sub pp_rv2av { deref(shift, $top, "\@"); }
+sub pp_rv2gv { deref(shift, $top, "*"); }
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '$';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
+ }
+ process($top, $op->private & OPpLVAL_INTRO ||
+ $op->private & OPpOUR_INTRO ? "intro" : "used");
+}
+
+sub pp_gv {
+ my $op = shift;
+ my $gv;
+ if ($Config{useithreads}) {
+ $top = $pad[$op->padix];
+ $top = UNKNOWN unless $top;
+ $top->[1] = '*';
+ }
+ else {
+ $gv = $op->gv;
+ $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
+ }
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ # constant could be in the pad (under useithreads)
+ if ($$sv) {
+ $top = ["?", "",
+ (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
+ ? cstring($sv->PV) : "?"];
+ }
+ else {
+ $top = $pad[$op->targ];
+ $top = UNKNOWN unless $top;
+ }
+}
+
+sub pp_method {
+ my $op = shift;
+ $top = ["(method)", "->".$top->[1], $top->[2]];
+}
+
+sub pp_entersub {
+ my $op = shift;
+ if ($top->[1] eq "m") {
+ process($top, "meth");
+ } else {
+ process($top, "subused");
+ }
+ $top = UNKNOWN;
+}
+
+#
+# Stuff for cross referencing definitions of variables and subs
+#
+
+sub B::GV::xref {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if ($$cv) {
+ #return if $done{$$cv}++;
+ $file = $gv->FILE;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
+ push(@todo, $cv);
+ }
+ my $form = $gv->FORM;
+ if ($$form) {
+ return if $done{$$form}++;
+ $file = $gv->FILE;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
+ }
+}
+
+sub xref_definitions {
+ my ($pack, %exclude);
+ return if $nodefs;
+ $subname = "(definitions)";
+ foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
+ strict vars FileHandle Exporter Carp PerlIO::Layer
+ attributes utf8 warnings)) {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
+}
+
+sub output {
+ return if $raw;
+ my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
+ $perpack, $pername, $perev);
+ foreach $file (sort(keys(%table))) {
+ $perfile = $table{$file};
+ print "File $file\n";
+ foreach $subname (sort(keys(%$perfile))) {
+ $persubname = $perfile->{$subname};
+ print " Subroutine $subname\n";
+ foreach $pack (sort(keys(%$persubname))) {
+ $perpack = $persubname->{$pack};
+ print " Package $pack\n";
+ foreach $name (sort(keys(%$perpack))) {
+ $pername = $perpack->{$name};
+ my @lines;
+ foreach $ev (qw(intro formdef subdef meth subused used)) {
+ $perev = $pername->{$ev};
+ if (defined($perev) && @$perev) {
+ my $code = $code{$ev};
+ push(@lines, map("$code$_", @$perev));
+ }
+ }
+ printf " %-16s %s\n", $name, join(", ", @lines);
+ }
+ }
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "d") {
+ $nodefs = 1;
+ } elsif ($opt eq "r") {
+ $raw = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "t") {
+ $debug_top = 1;
+ }
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ xref_definitions();
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "xref_object(\\&$objname)";
+ die "xref_object(\\&$objname) failed: $@" if $@;
+ }
+ output();
+ }
+ } else {
+ return sub {
+ xref_definitions();
+ xref_main();
+ output();
+ }
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CGI/Apache.pm b/Master/tlpkg/tlperl/lib/CGI/Apache.pm
new file mode 100644
index 00000000000..e055e305551
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Apache.pm
@@ -0,0 +1,27 @@
+package CGI::Apache;
+use CGI;
+
+$VERSION = '1.01';
+
+1;
+__END__
+
+=head1 NAME
+
+CGI::Apache - Backward compatibility module for CGI.pm
+
+=head1 SYNOPSIS
+
+Do not use this module. It is deprecated.
+
+=head1 ABSTRACT
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR INFORMATION
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CGI/Carp.pm b/Master/tlpkg/tlperl/lib/CGI/Carp.pm
new file mode 100644
index 00000000000..5f9911b32e5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Carp.pm
@@ -0,0 +1,601 @@
+package CGI::Carp;
+
+=head1 NAME
+
+B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
+
+=head1 SYNOPSIS
+
+ use CGI::Carp;
+
+ croak "We're outta here!";
+ confess "It was my fault: $!";
+ carp "It was your fault!";
+ warn "I'm confused";
+ die "I'm dying.\n";
+
+ use CGI::Carp qw(cluck);
+ cluck "I wouldn't do that if I were you";
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Fatal error messages are now sent to browser";
+
+=head1 DESCRIPTION
+
+CGI scripts have a nasty habit of leaving warning messages in the error
+logs that are neither time stamped nor fully identified. Tracking down
+the script that caused the error is a pain. This fixes that. Replace
+the usual
+
+ use Carp;
+
+with
+
+ use CGI::Carp
+
+And the standard warn(), die (), croak(), confess() and carp() calls
+will automagically be replaced with functions that write out nicely
+time-stamped messages to the HTTP server error log.
+
+For example:
+
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
+ [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
+
+=head1 REDIRECTING ERROR MESSAGES
+
+By default, error messages are sent to STDERR. Most HTTPD servers
+direct STDERR to the server's error log. Some applications may wish
+to keep private error logs, distinct from the server's error log, or
+they may wish to direct error messages to STDOUT so that the browser
+will receive them.
+
+The C<carpout()> function is provided for this purpose. Since
+carpout() is not exported by default, you must import it explicitly by
+saying
+
+ use CGI::Carp qw(carpout);
+
+The carpout() function requires one argument, which should be a
+reference to an open filehandle for writing errors. It should be
+called in a C<BEGIN> block at the top of the CGI application so that
+compiler errors will be caught. Example:
+
+ BEGIN {
+ use CGI::Carp qw(carpout);
+ open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
+ die("Unable to open mycgi-log: $!\n");
+ carpout(LOG);
+ }
+
+carpout() does not handle file locking on the log for you at this point.
+Also, note that carpout() does not work with in-memory file handles, although
+a patch would be welcome to address that.
+
+The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some
+servers, when dealing with CGI scripts, close their connection to the
+browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to
+prevent this from happening prematurely.
+
+You can pass filehandles to carpout() in a variety of ways. The "correct"
+way according to Tom Christiansen is to pass a reference to a filehandle
+GLOB:
+
+ carpout(\*LOG);
+
+This looks weird to mere mortals however, so the following syntaxes are
+accepted as well:
+
+ carpout(LOG);
+ carpout(main::LOG);
+ carpout(main'LOG);
+ carpout(\LOG);
+ carpout(\'main::LOG');
+
+ ... and so on
+
+FileHandle and other objects work as well.
+
+Use of carpout() is not great for performance, so it is recommended
+for debugging purposes or for moderate-use applications. A future
+version of this module may delay redirecting STDERR until one of the
+CGI::Carp methods is called to prevent the performance hit.
+
+=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
+
+If you want to send fatal (die, confess) errors to the browser, ask to
+import the special "fatalsToBrowser" subroutine:
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Bad error here";
+
+Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
+arranges to send a minimal HTTP header to the browser so that even errors that
+occur in the early compile phase will be seen.
+Nonfatal errors will still be directed to the log file only (unless redirected
+with carpout).
+
+Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
+and higher.
+
+=head2 Changing the default message
+
+By default, the software error message is followed by a note to
+contact the Webmaster by e-mail with the time and date of the error.
+If this message is not to your liking, you can change it using the
+set_message() routine. This is not imported by default; you should
+import it on the use() line:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ set_message("It's not a bug, it's a feature!");
+
+You may also pass in a code reference in order to create a custom
+error message. At run time, your code will be called with the text
+of the error message that caused the script to die. Example:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+ }
+ set_message(\&handle_errors);
+ }
+
+In order to correctly intercept compile-time errors, you should call
+set_message() from within a BEGIN{} block.
+
+=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
+
+If fatalsToBrowser in conjunction with set_message does not provide
+you with all of the functionality you need, you can go one step
+further by specifying a function to be executed any time a script
+calls "die", has a syntax error, or dies unexpectedly at runtime
+with a line like "undef->explode();".
+
+ use CGI::Carp qw(set_die_handler);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "content-type: text/html\n\n";
+ print "<h1>Oh gosh</h1>";
+ print "<p>Got an error: $msg</p>";
+
+ #proceed to send an email to a system administrator,
+ #write a detailed message to the browser and/or a log,
+ #etc....
+ }
+ set_die_handler(\&handle_errors);
+ }
+
+Notice that if you use set_die_handler(), you must handle sending
+HTML headers to the browser yourself if you are printing a message.
+
+If you use set_die_handler(), you will most likely interfere with
+the behavior of fatalsToBrowser, so you must use this or that, not
+both.
+
+Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
+and there is only one SIG{__DIE__}. This means that if you are
+attempting to set SIG{__DIE__} yourself, you may interfere with
+this module's functionality, or this module may interfere with
+your module's functionality.
+
+=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
+
+It is now also possible to make non-fatal errors appear as HTML
+comments embedded in the output of your program. To enable this
+feature, export the new "warningsToBrowser" subroutine. Since sending
+warnings to the browser before the HTTP headers have been sent would
+cause an error, any warnings are stored in an internal buffer until
+you call the warningsToBrowser() subroutine with a true argument:
+
+ use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
+ use CGI qw(:standard);
+ print header();
+ warningsToBrowser(1);
+
+You may also give a false argument to warningsToBrowser() to prevent
+warnings from being sent to the browser while you are printing some
+content where HTML comments are not allowed:
+
+ warningsToBrowser(0); # disable warnings
+ print "<script type=\"text/javascript\"><!--\n";
+ print_some_javascript_code();
+ print "//--></script>\n";
+ warningsToBrowser(1); # re-enable warnings
+
+Note: In this respect warningsToBrowser() differs fundamentally from
+fatalsToBrowser(), which you should never call yourself!
+
+=head1 OVERRIDING THE NAME OF THE PROGRAM
+
+CGI::Carp includes the name of the program that generated the error or
+warning in the messages written to the log and the browser window.
+Sometimes, Perl can get confused about what the actual name of the
+executed program was. In these cases, you can override the program
+name that CGI::Carp will use for all messages.
+
+The quick way to do that is to tell CGI::Carp the name of the program
+in its use statement. You can do that by adding
+"name=cgi_carp_log_name" to your "use" statement. For example:
+
+ use CGI::Carp qw(name=cgi_carp_log_name);
+
+. If you want to change the program name partway through the program,
+you can use the C<set_progname()> function instead. It is not
+exported by default, you must import it explicitly by saying
+
+ use CGI::Carp qw(set_progname);
+
+Once you've done that, you can change the logged name of the program
+at any time by calling
+
+ set_progname(new_program_name);
+
+You can set the program back to the default by calling
+
+ set_progname(undef);
+
+Note that this override doesn't happen until after the program has
+compiled, so any compile-time errors will still show up with the
+non-overridden program name
+
+=head1 CHANGE LOG
+
+1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
+ not behaving correctly in an eval() context.
+
+1.05 carpout() added and minor corrections by Marc Hedlund
+ <hedlund@best.com> on 11/26/95.
+
+1.06 fatalsToBrowser() no longer aborts for fatal errors within
+ eval() statements.
+
+1.08 set_message() added and carpout() expanded to allow for FileHandle
+ objects.
+
+1.09 set_message() now allows users to pass a code REFERENCE for
+ really custom error messages. croak and carp are now
+ exported by default. Thanks to Gunther Birznieks for the
+ patches.
+
+1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
+ module to run correctly under mod_perl.
+
+1.11 Changed order of &gt; and &lt; escapes.
+
+1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
+
+1.13 Added cluck() to make the module orthogonal with Carp.
+ More mod_perl related fixes.
+
+1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
+ warningsToBrowser(). Replaced <CODE> tags with <PRE> in
+ fatalsToBrowser() output.
+
+1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
+ (hack alert!) in order to accommodate various combinations of Perl and
+ mod_perl.
+
+1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
+ for overriding program name.
+
+1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
+ former isn't working in some people's hands. There is no such thing
+ as reliable exception handling in Perl.
+
+1.27 Replaced tell STDOUT with bytes=tell STDOUT.
+
+=head1 AUTHORS
+
+Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 SEE ALSO
+
+Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
+CGI::Response
+
+=cut
+
+require 5.000;
+use Exporter;
+#use Carp;
+BEGIN {
+ require Carp;
+ *CORE::GLOBAL::die = \&CGI::Carp::die;
+}
+
+use File::Spec;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+
+$CGI::Carp::VERSION = '3.45';
+$CGI::Carp::CUSTOM_MSG = undef;
+$CGI::Carp::DIE_HANDLER = undef;
+
+
+# fancy import routine detects and handles 'errorWrap' specially.
+sub import {
+ my $pkg = shift;
+ my(%routines);
+ my(@name);
+ if (@name=grep(/^name=/,@_))
+ {
+ my($n) = (split(/=/,$name[0]))[1];
+ set_progname($n);
+ @_=grep(!/^name=/,@_);
+ }
+
+ grep($routines{$_}++,@_,@EXPORT);
+ $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+ $WARN++ if $routines{'warningsToBrowser'};
+ my($oldlevel) = $Exporter::ExportLevel;
+ $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,keys %routines);
+ $Exporter::ExportLevel = $oldlevel;
+ $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
+# $pkg->export('CORE::GLOBAL','die');
+}
+
+# These are the originals
+sub realwarn { CORE::warn(@_); }
+sub realdie { CORE::die(@_); }
+
+sub id {
+ my $level = shift;
+ my($pack,$file,$line,$sub) = caller($level);
+ my($dev,$dirs,$id) = File::Spec->splitpath($file);
+ return ($file,$line,$id);
+}
+
+sub stamp {
+ my $time = scalar(localtime);
+ my $frame = 0;
+ my ($id,$pack,$file,$dev,$dirs);
+ if (defined($CGI::Carp::PROGNAME)) {
+ $id = $CGI::Carp::PROGNAME;
+ } else {
+ do {
+ $id = $file;
+ ($pack,$file) = caller($frame++);
+ } until !$file;
+ }
+ ($dev,$dirs,$id) = File::Spec->splitpath($id);
+ return "[$time] $id: ";
+}
+
+sub set_progname {
+ $CGI::Carp::PROGNAME = shift;
+ return $CGI::Carp::PROGNAME;
+}
+
+
+sub warn {
+ my $message = shift;
+ my($file,$line,$id) = id(1);
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ _warn($message) if $WARN;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realwarn $message;
+}
+
+sub _warn {
+ my $msg = shift;
+ if ($EMIT_WARNINGS) {
+ # We need to mangle the message a bit to make it a valid HTML
+ # comment. This is done by substituting similar-looking ISO
+ # 8859-1 characters for <, > and -. This is a hack.
+ $msg =~ tr/<>-/\253\273\255/;
+ chomp $msg;
+ print STDOUT "<!-- warning: $msg -->\n";
+ } else {
+ push @WARNINGS, $msg;
+ }
+}
+
+
+# The mod_perl package Apache::Registry loads CGI programs by calling
+# eval. These evals don't count when looking at the stack backtrace.
+sub _longmess {
+ my $message = Carp::longmess();
+ $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
+ if exists $ENV{MOD_PERL};
+ return $message;
+}
+
+sub ineval {
+ (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
+}
+
+sub die {
+ my ($arg,@rest) = @_;
+
+ &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
+
+ # if called as die( $object, 'string' ),
+ # all is stringified, just like with
+ # the real 'die'
+ $arg = join '' => "$arg", @rest if @rest;
+
+ $arg ||= 'Died';
+
+ my($file,$line,$id) = id(1);
+
+ $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
+
+ realdie $arg if ineval();
+ &fatalsToBrowser($arg) if $WRAP;
+
+ $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
+
+ $arg .= "\n" unless $arg =~ /\n$/;
+
+ realdie $arg;
+}
+
+sub set_message {
+ $CGI::Carp::CUSTOM_MSG = shift;
+ return $CGI::Carp::CUSTOM_MSG;
+}
+
+sub set_die_handler {
+
+ my ($handler) = shift;
+
+ #setting SIG{__DIE__} here is necessary to catch runtime
+ #errors which are not called by literally saying "die",
+ #such as the line "undef->explode();". however, doing this
+ #will interfere with fatalsToBrowser, which also sets
+ #SIG{__DIE__} in the import() function above (or the
+ #import() function above may interfere with this). for
+ #this reason, you should choose to either set the die
+ #handler here, or use fatalsToBrowser, not both.
+ $main::SIG{__DIE__} = $handler;
+
+ $CGI::Carp::DIE_HANDLER = $handler;
+
+ return $CGI::Carp::DIE_HANDLER;
+}
+
+sub confess { CGI::Carp::die Carp::longmess @_; }
+sub croak { CGI::Carp::die Carp::shortmess @_; }
+sub carp { CGI::Carp::warn Carp::shortmess @_; }
+sub cluck { CGI::Carp::warn Carp::longmess @_; }
+
+# We have to be ready to accept a filehandle as a reference
+# or a string.
+sub carpout {
+ my($in) = @_;
+ my($no) = fileno(to_filehandle($in));
+ realdie("Invalid filehandle $in\n") unless defined $no;
+
+ open(SAVEERR, ">&STDERR");
+ open(STDERR, ">&$no") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+}
+
+sub warningsToBrowser {
+ $EMIT_WARNINGS = @_ ? shift : 1;
+ _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
+# headers
+sub fatalsToBrowser {
+ my $msg = shift;
+
+ $msg = "$msg" if ref $msg;
+
+ $msg=~s/&/&amp;/g;
+ $msg=~s/>/&gt;/g;
+ $msg=~s/</&lt;/g;
+ $msg=~s/"/&quot;/g;
+
+ my($wm) = $ENV{SERVER_ADMIN} ?
+ qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
+ "this site's webmaster";
+ my ($outer_message) = <<END;
+For help, please send mail to $wm, giving this error message
+and the time and date of the error.
+END
+ ;
+ my $mod_perl = exists $ENV{MOD_PERL};
+
+ if ($CUSTOM_MSG) {
+ if (ref($CUSTOM_MSG) eq 'CODE') {
+ print STDOUT "Content-type: text/html\n\n"
+ unless $mod_perl;
+ eval {
+ &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+ };
+ if ($@) { print STDERR q(error while executing the error handler: $@); }
+
+ return;
+ } else {
+ $outer_message = $CUSTOM_MSG;
+ }
+ }
+
+ my $mess = <<END;
+<h1>Software error:</h1>
+<pre>$msg</pre>
+<p>
+$outer_message
+</p>
+END
+ ;
+
+ if ($mod_perl) {
+ my $r;
+ if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $mod_perl = 2;
+ require Apache2::RequestRec;
+ require Apache2::RequestIO;
+ require Apache2::RequestUtil;
+ require APR::Pool;
+ require ModPerl::Util;
+ require Apache2::Response;
+ $r = Apache2::RequestUtil->request;
+ }
+ else {
+ $r = Apache->request;
+ }
+ # If bytes have already been sent, then
+ # we print the message out directly.
+ # Otherwise we make a custom error
+ # handler to produce the doc for us.
+ if ($r->bytes_sent) {
+ $r->print($mess);
+ $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
+ } else {
+ # MSIE won't display a custom 500 response unless it is >512 bytes!
+ if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
+ $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
+ }
+ $r->custom_response(500,$mess);
+ }
+ } else {
+ my $bytes_written = eval{tell STDOUT};
+ if (defined $bytes_written && $bytes_written > 0) {
+ print STDOUT $mess;
+ }
+ else {
+ print STDOUT "Status: 500\n";
+ print STDOUT "Content-type: text/html\n\n";
+ print STDOUT $mess;
+ }
+ }
+
+ warningsToBrowser(1); # emit warnings before dying
+}
+
+# Cut and paste from CGI.pm so that we don't have the overhead of
+# always loading the entire CGI module.
+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;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CGI/Cookie.pm b/Master/tlpkg/tlperl/lib/CGI/Cookie.pm
new file mode 100644
index 00000000000..7bc090d4186
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Cookie.pm
@@ -0,0 +1,549 @@
+package CGI::Cookie;
+
+use strict;
+use warnings;
+
+# 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-1999, 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.
+
+$CGI::Cookie::VERSION='1.29';
+
+use CGI::Util qw(rearrange unescape escape);
+use CGI;
+use overload '""' => \&as_string,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+my $PERLEX = 0;
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Turn on special checking for Doug MacEachern's modperl
+# PerlEx::DBI tries to fool DBI by setting MOD_PERL
+my $MOD_PERL = 0;
+if (exists $ENV{MOD_PERL} && ! $PERLEX) {
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::RequestUtil;
+ require APR::Table;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
+ }
+}
+
+# fetch a list of cookies from the environment and
+# return as a hash. the cookies are parsed as normal
+# escaped URL data.
+sub fetch {
+ my $class = shift;
+ my $raw_cookie = get_raw_cookie(@_) or return;
+ return $class->parse($raw_cookie);
+}
+
+# Fetch a list of cookies from the environment or the incoming headers and
+# return as a hash. The cookie values are not unescaped or altered in any way.
+ sub raw_fetch {
+ my $class = shift;
+ my $raw_cookie = get_raw_cookie(@_) or return;
+ my %results;
+ my($key,$value);
+
+ my @pairs = split("[;,] ?",$raw_cookie);
+ foreach (@pairs) {
+ s/\s*(.*?)\s*/$1/;
+ if (/^([^=]+)=(.*)/) {
+ $key = $1;
+ $value = $2;
+ }
+ else {
+ $key = $_;
+ $value = '';
+ }
+ $results{$key} = $value;
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub get_raw_cookie {
+ my $r = shift;
+ $r ||= eval { $MOD_PERL == 2 ?
+ Apache2::RequestUtil->request() :
+ Apache->request } if $MOD_PERL;
+
+ return $r->headers_in->{'Cookie'} if $r;
+
+ die "Run $r->subprocess_env; before calling fetch()"
+ if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
+
+ return $ENV{HTTP_COOKIE} || $ENV{COOKIE};
+}
+
+
+sub parse {
+ my ($self,$raw_cookie) = @_;
+ my %results;
+
+ my @pairs = split("[;,] ?",$raw_cookie);
+ foreach (@pairs) {
+ s/\s*(.*?)\s*/$1/;
+ my($key,$value) = split("=",$_,2);
+
+ # Some foreign cookies are not in name=value format, so ignore
+ # them.
+ next if !defined($value);
+ my @values = ();
+ if ($value ne '') {
+ @values = map unescape($_),split(/[&;]/,$value.'&dmy');
+ pop @values;
+ }
+ $key = unescape($key);
+ # A bug in Netscape can cause several cookies with same name to
+ # appear. The FIRST one in HTTP_COOKIE is the most recent version.
+ $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) if ref($class);
+ # Ignore mod_perl request object--compatability with Apache::Cookie.
+ shift if ref $_[0]
+ && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
+ HTTPONLY / ], @_);
+
+ # Pull out our parameters.
+ my @values;
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+
+ bless my $self = {
+ 'name'=>$name,
+ 'value'=>[@values],
+ },$class;
+
+ # IE requires the path and domain to be present for some reason.
+ $path ||= "/";
+ # however, this breaks networks which use host tables without fully qualified
+ # names, so we comment it out.
+ # $domain = CGI::virtual_host() unless defined $domain;
+
+ $self->path($path) if defined $path;
+ $self->domain($domain) if defined $domain;
+ $self->secure($secure) if defined $secure;
+ $self->expires($expires) if defined $expires;
+ $self->httponly($httponly) if defined $httponly;
+# $self->max_age($expires) if defined $expires;
+ return $self;
+}
+
+sub as_string {
+ my $self = shift;
+ return "" unless $self->name;
+
+ my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly);
+
+ push(@constant_values,"domain=$domain") if $domain = $self->domain;
+ push(@constant_values,"path=$path") if $path = $self->path;
+ push(@constant_values,"expires=$expires") if $expires = $self->expires;
+ push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
+ push(@constant_values,"secure") if $secure = $self->secure;
+ push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
+
+ my($key) = escape($self->name);
+ my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
+ return join("; ",$cookie,@constant_values);
+}
+
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+
+sub bake {
+ my ($self, $r) = @_;
+
+ $r ||= eval {
+ $MOD_PERL == 2
+ ? Apache2::RequestUtil->request()
+ : Apache->request
+ } if $MOD_PERL;
+ if ($r) {
+ $r->headers_out->add('Set-Cookie' => $self->as_string);
+ } else {
+ print CGI::header(-cookie => $self);
+ }
+
+}
+
+# accessors
+sub name {
+ my $self = shift;
+ my $name = shift;
+ $self->{'name'} = $name if defined $name;
+ return $self->{'name'};
+}
+
+sub value {
+ my $self = shift;
+ my $value = shift;
+ if (defined $value) {
+ my @values;
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+ $self->{'value'} = [@values];
+ }
+ return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
+}
+
+sub domain {
+ my $self = shift;
+ my $domain = shift;
+ $self->{'domain'} = lc $domain if defined $domain;
+ return $self->{'domain'};
+}
+
+sub secure {
+ my $self = shift;
+ my $secure = shift;
+ $self->{'secure'} = $secure if defined $secure;
+ return $self->{'secure'};
+}
+
+sub expires {
+ my $self = shift;
+ my $expires = shift;
+ $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
+ return $self->{'expires'};
+}
+
+sub max_age {
+ my $self = shift;
+ my $expires = shift;
+ $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
+ return $self->{'max-age'};
+}
+
+sub path {
+ my $self = shift;
+ my $path = shift;
+ $self->{'path'} = $path if defined $path;
+ return $self->{'path'};
+}
+
+
+sub httponly { # HttpOnly
+ my $self = shift;
+ my $httponly = shift;
+ $self->{'httponly'} = $httponly if defined $httponly;
+ return $self->{'httponly'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Cookie - Interface to Netscape Cookies
+
+=head1 SYNOPSIS
+
+ use CGI qw/:standard/;
+ use CGI::Cookie;
+
+ # Create new cookies and send them
+ $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
+ $cookie2 = new CGI::Cookie(-name=>'preferences',
+ -value=>{ font => Helvetica,
+ size => 12 }
+ );
+ print header(-cookie=>[$cookie1,$cookie2]);
+
+ # fetch existing cookies
+ %cookies = fetch CGI::Cookie;
+ $id = $cookies{'ID'}->value;
+
+ # create cookies returned from an external source
+ %cookies = parse CGI::Cookie($ENV{COOKIE});
+
+=head1 DESCRIPTION
+
+CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
+innovation that allows Web servers to store persistent information on
+the browser's side of the connection. Although CGI::Cookie is
+intended to be used in conjunction with CGI.pm (and is in fact used by
+it internally), you can use this module independently.
+
+For full information on cookies see
+
+ http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
+
+=head1 USING CGI::Cookie
+
+CGI::Cookie is object oriented. Each cookie object has a name and a
+value. The name is any scalar value. The value is any scalar or
+array value (associative arrays are also allowed). Cookies also have
+several optional attributes, including:
+
+=over 4
+
+=item B<1. expiration date>
+
+The expiration date tells the browser how long to hang on to the
+cookie. If the cookie specifies an expiration date in the future, the
+browser will store the cookie information in a disk file and return it
+to the server every time the user reconnects (until the expiration
+date is reached). If the cookie species an expiration date in the
+past, the browser will remove the cookie from the disk file. If the
+expiration date is not specified, the cookie will persist only until
+the user quits the browser.
+
+=item B<2. 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 Netscape will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"ftp.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 B<3. 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, the path is set to "/", so
+that all scripts at your site will receive the cookie.
+
+=item B<4. 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.
+
+=item B<4. httponly flag>
+
+If the "httponly" attribute is set, the cookie will only be accessible
+through HTTP Requests. This cookie will be inaccessible via JavaScript
+(to prevent XSS attacks).
+
+But, currently this feature only used and recognised by
+MS Internet Explorer 6 Service Pack 1 and later.
+
+See this URL for more information:
+
+L<http://msdn.microsoft.com/en-us/library/ms533046%28VS.85%29.aspx>
+
+=back
+
+=head2 Creating New Cookies
+
+ my $c = new CGI::Cookie(-name => 'foo',
+ -value => 'bar',
+ -expires => '+3M',
+ -domain => '.capricorn.com',
+ -path => '/cgi-bin/database',
+ -secure => 1
+ );
+
+Create cookies from scratch with the B<new> method. The B<-name> and
+B<-value> parameters are required. The name must be a scalar value.
+The value can be a scalar, an array reference, or a hash reference.
+(At some point in the future cookies will support one of the Perl
+object serialization protocols for full generality).
+
+B<-expires> accepts any of the relative or absolute date formats
+recognized by CGI.pm, for example "+3M" for three months in the
+future. See CGI.pm's documentation for details.
+
+B<-domain> points to a domain name or to a fully qualified host name.
+If not specified, the cookie will be returned only to the Web server
+that created it.
+
+B<-path> points to a partial URL on the current server. The cookie
+will be returned to all URLs beginning with the specified path. If
+not specified, it defaults to '/', which returns the cookie to all
+pages at your site.
+
+B<-secure> if set to a true value instructs the browser to return the
+cookie only when a cryptographic protocol is in use.
+
+B<-httponly> if set to a true value, the cookie will not be accessible
+via JavaScript.
+
+For compatibility with Apache::Cookie, you may optionally pass in
+a mod_perl request object as the first argument to C<new()>. It will
+simply be ignored:
+
+ my $c = new CGI::Cookie($r,
+ -name => 'foo',
+ -value => ['bar','baz']);
+
+=head2 Sending the Cookie to the Browser
+
+The simplest way to send a cookie to the browser is by calling the bake()
+method:
+
+ $c->bake;
+
+Under mod_perl, pass in an Apache request object:
+
+ $c->bake($r);
+
+If you want to set the cookie yourself, Within a CGI script you can send
+a cookie to the browser by creating one or more Set-Cookie: fields in the
+HTTP header. Here is a typical sequence:
+
+ my $c = new CGI::Cookie(-name => 'foo',
+ -value => ['bar','baz'],
+ -expires => '+3M');
+
+ print "Set-Cookie: $c\n";
+ print "Content-Type: text/html\n\n";
+
+To send more than one cookie, create several Set-Cookie: fields.
+
+If you are using CGI.pm, you send cookies by providing a -cookie
+argument to the header() method:
+
+ print header(-cookie=>$c);
+
+Mod_perl users can set cookies using the request object's header_out()
+method:
+
+ $r->headers_out->set('Set-Cookie' => $c);
+
+Internally, Cookie overloads the "" operator to call its as_string()
+method when incorporated into the HTTP header. as_string() turns the
+Cookie's internal representation into an RFC-compliant text
+representation. You may call as_string() yourself if you prefer:
+
+ print "Set-Cookie: ",$c->as_string,"\n";
+
+=head2 Recovering Previous Cookies
+
+ %cookies = fetch CGI::Cookie;
+
+B<fetch> returns an associative array consisting of all cookies
+returned by the browser. The keys of the array are the cookie names. You
+can iterate through the cookies this way:
+
+ %cookies = fetch CGI::Cookie;
+ foreach (keys %cookies) {
+ do_something($cookies{$_});
+ }
+
+In a scalar context, fetch() returns a hash reference, which may be more
+efficient if you are manipulating multiple cookies.
+
+CGI.pm uses the URL escaping methods to save and restore reserved characters
+in its cookies. If you are trying to retrieve a cookie set by a foreign server,
+this escaping method may trip you up. Use raw_fetch() instead, which has the
+same semantics as fetch(), but performs no unescaping.
+
+You may also retrieve cookies that were stored in some external
+form using the parse() class method:
+
+ $COOKIES = `cat /usr/tmp/Cookie_stash`;
+ %cookies = parse CGI::Cookie($COOKIES);
+
+If you are in a mod_perl environment, you can save some overhead by
+passing the request object to fetch() like this:
+
+ CGI::Cookie->fetch($r);
+
+=head2 Manipulating Cookies
+
+Cookie objects have a series of accessor methods to get and set cookie
+attributes. Each accessor has a similar syntax. Called without
+arguments, the accessor returns the current value of the attribute.
+Called with an argument, the accessor changes the attribute and
+returns its new value.
+
+=over 4
+
+=item B<name()>
+
+Get or set the cookie's name. Example:
+
+ $name = $c->name;
+ $new_name = $c->name('fred');
+
+=item B<value()>
+
+Get or set the cookie's value. Example:
+
+ $value = $c->value;
+ @new_value = $c->value(['a','b','c','d']);
+
+B<value()> is context sensitive. In a list context it will return
+the current value of the cookie as an array. In a scalar context it
+will return the B<first> value of a multivalued cookie.
+
+=item B<domain()>
+
+Get or set the cookie's domain.
+
+=item B<path()>
+
+Get or set the cookie's path.
+
+=item B<expires()>
+
+Get or set the cookie's expiration time.
+
+=back
+
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CGI/Fast.pm b/Master/tlpkg/tlperl/lib/CGI/Fast.pm
new file mode 100644
index 00000000000..e31dac3f50f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Fast.pm
@@ -0,0 +1,224 @@
+package CGI::Fast;
+use strict;
+
+# A way to say "use warnings" that's compatible with even older perls.
+# making it local will not affect the code that loads this module
+# and since we're not in a BLOCK, warnings are enabled until the EOF
+local $^W = 1;
+
+# 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,1996, 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.
+
+$CGI::Fast::VERSION='1.08';
+
+use CGI;
+use FCGI;
+# use vars works like "our", but is compatible with older Perls.
+use vars qw(
+ @ISA
+ $ignore
+);
+@ISA = ('CGI');
+
+# workaround for known bug in libfcgi
+while (($ignore) = each %ENV) { }
+
+# override the initialization behavior so that
+# state is NOT maintained between invocations
+sub save_request {
+ # no-op
+}
+
+# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
+# in this package variable.
+use vars qw($Ext_Request);
+BEGIN {
+ # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket,
+ # and keep the request handle around from which to call Accept().
+ if ($ENV{FCGI_SOCKET_PATH}) {
+ my $path = $ENV{FCGI_SOCKET_PATH};
+ my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
+ my $socket = FCGI::OpenSocket( $path, $backlog );
+ $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
+ \%ENV, $socket, 1 );
+ }
+}
+
+# New is slightly different in that it calls FCGI's
+# accept() method.
+sub new {
+ my ($self, $initializer, @param) = @_;
+ unless (defined $initializer) {
+ if ($Ext_Request) {
+ return undef unless $Ext_Request->Accept() >= 0;
+ } else {
+ return undef unless FCGI::accept() >= 0;
+ }
+ }
+ CGI->_reset_globals;
+ $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
+ return $CGI::Q = $self->SUPER::new($initializer, @param);
+}
+
+1;
+
+=head1 NAME
+
+CGI::Fast - CGI Interface for Fast CGI
+
+=head1 SYNOPSIS
+
+ use CGI::Fast qw(:standard);
+ $COUNTER = 0;
+ while (new CGI::Fast) {
+ print header;
+ print start_html("Fast CGI Rocks");
+ print
+ h1("Fast CGI Rocks"),
+ "Invocation number ",b($COUNTER++),
+ " PID ",b($$),".",
+ hr;
+ print end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Fast is a subclass of the CGI object created by CGI.pm. It is
+specialized to work well FCGI module, which greatly speeds up CGI
+scripts by turning them into persistently running server processes.
+Scripts that perform time-consuming initialization processes, such as
+loading large modules or opening persistent database connections, will
+see large performance improvements.
+
+=head1 OTHER PIECES OF THE PUZZLE
+
+In order to use CGI::Fast you'll need the FCGI module. See
+http://www.cpan.org/ for details.
+
+=head1 WRITING FASTCGI PERL SCRIPTS
+
+FastCGI scripts are persistent: one or more copies of the script
+are started up when the server initializes, and stay around until
+the server exits or they die a natural death. After performing
+whatever one-time initialization it needs, the script enters a
+loop waiting for incoming connections, processing the request, and
+waiting some more.
+
+A typical FastCGI script will look like this:
+
+ #!/usr/bin/perl
+ use CGI::Fast;
+ &do_some_initialization();
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+Each time there's a new request, CGI::Fast returns a
+CGI object to your loop. The rest of the time your script
+waits in the call to new(). When the server requests that
+your script be terminated, new() will return undef. You can
+of course exit earlier if you choose. A new version of the
+script will be respawned to take its place (this may be
+necessary in order to avoid Perl memory leaks in long-running
+scripts).
+
+CGI.pm's default CGI object mode also works. Just modify the loop
+this way:
+
+ while (new CGI::Fast) {
+ &process_request;
+ }
+
+Calls to header(), start_form(), etc. will all operate on the
+current request.
+
+=head1 INSTALLING FASTCGI SCRIPTS
+
+See the FastCGI developer's kit documentation for full details. On
+the Apache server, the following line must be added to srm.conf:
+
+ AddType application/x-httpd-fcgi .fcgi
+
+FastCGI scripts must end in the extension .fcgi. For each script you
+install, you must add something like the following to srm.conf:
+
+ FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
+
+This instructs Apache to launch two copies of file_upload.fcgi at
+startup time.
+
+=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
+
+Any script that works correctly as a FastCGI script will also work
+correctly when installed as a vanilla CGI script. However it will
+not see any performance benefit.
+
+=head1 EXTERNAL FASTCGI SERVER INVOCATION
+
+FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
+external to the webserver, perhaps on a remote machine. To configure the
+webserver to connect to an external FastCGI server, you would add the following
+to your srm.conf:
+
+ FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
+
+Two environment variables affect how the C<CGI::Fast> object is created,
+allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI>
+documentation for C<FCGI::OpenSocket> for more information.)
+
+=over
+
+=item FCGI_SOCKET_PATH
+
+The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
+script to which bind an listen for incoming connections from the web server.
+
+=item FCGI_LISTEN_QUEUE
+
+Maximum length of the queue of pending connections.
+
+=back
+
+For example:
+
+ #!/usr/local/bin/perl # must be a FastCGI version of perl!
+ use CGI::Fast;
+ &do_some_initialization();
+ $ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
+ $ENV{FCGI_LISTEN_QUEUE} = 100;
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+=head1 CAVEATS
+
+I haven't tested this very much.
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CGI/Pretty.pm b/Master/tlpkg/tlperl/lib/CGI/Pretty.pm
new file mode 100644
index 00000000000..356747824d5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Pretty.pm
@@ -0,0 +1,312 @@
+package CGI::Pretty;
+
+# 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).
+
+use strict;
+use CGI ();
+
+$CGI::Pretty::VERSION = '3.46';
+$CGI::DefaultClass = __PACKAGE__;
+$CGI::Pretty::AutoloadClass = 'CGI';
+@CGI::Pretty::ISA = qw( CGI );
+
+initialize_globals();
+
+sub _prettyPrint {
+ my $input = shift;
+ return if !$$input;
+ return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
+
+# print STDERR "'", $$input, "'\n";
+
+ foreach my $i ( @CGI::Pretty::AS_IS ) {
+ if ( $$input =~ m{</$i>}si ) {
+ my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
+ next if !$b;
+ $a ||= "";
+ $c ||= "";
+
+ _prettyPrint( \$a ) if $a;
+ _prettyPrint( \$c ) if $c;
+
+ $b ||= "";
+ $$input = "$a$b$c";
+ return;
+ }
+ }
+ $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
+}
+
+sub comment {
+ my($self,@p) = CGI::self_or_CGI(@_);
+
+ my $s = "@p";
+ $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK;
+
+ return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub _make_tag_func {
+ my ($self,$tagname) = @_;
+
+ # As Lincoln as noted, the last else clause is VERY hairy, and it
+ # took me a while to figure out what I was trying to do.
+ # What it does is look for tags that shouldn't be indented (e.g. PRE)
+ # and makes sure that when we nest tags, those tags don't get
+ # indented.
+ # For an example, try print td( pre( "hello\nworld" ) );
+ # If we didn't care about stuff like that, the code would be
+ # MUCH simpler. BTW: I won't claim to be a regular expression
+ # guru, so if anybody wants to contribute something that would
+ # be quicker, easier to read, etc, I would be more than
+ # willing to put it in - Brian
+
+ my $func = qq"
+ sub $tagname {";
+
+ $func .= q'
+ shift if $_[0] &&
+ (ref($_[0]) &&
+ (substr(ref($_[0]),0,3) eq "CGI" ||
+ UNIVERSAL::isa($_[0],"CGI")));
+ my($attr) = "";
+ if (ref($_[0]) && ref($_[0]) eq "HASH") {
+ my(@attr) = make_attributes(shift()||undef,1);
+ $attr = " @attr" if @attr;
+ }';
+
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq!
+ return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq!
+ return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
+ } else {
+ $func .= qq#
+ return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
+ \$CGI::Pretty::LINEBREAK unless \@_;
+ my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
+
+ my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
+ my \@args;
+ if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
+ if(ref(\$_[0]) eq 'ARRAY') {
+ \@args = \@{\$_[0]}
+ } else {
+ foreach (\@_) {
+ \$args[0] .= \$_;
+ \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
+ chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
+
+ \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
+ }
+ chop \$args[0] unless \$" eq "";
+ }
+ }
+ else {
+ \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
+ }
+
+ my \@result;
+ if ( exists \$ASIS{ "\L$tagname\E" } ) {
+ \@result = map { "\$tag\$_\$untag" } \@args;
+ }
+ else {
+ \@result = map {
+ chomp;
+ my \$tmp = \$_;
+ CGI::Pretty::_prettyPrint( \\\$tmp );
+ \$tag . \$CGI::Pretty::LINEBREAK .
+ \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK .
+ \$untag . \$CGI::Pretty::LINEBREAK
+ } \@args;
+ }
+ if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
+ return join ("", \@result);
+ } else {
+ return "\@result";
+ }
+ }#;
+ }
+
+ return $func;
+}
+
+sub start_html {
+ return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub end_html {
+ return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
+}
+
+sub new {
+ my $class = shift;
+ my $this = $class->SUPER::new( @_ );
+
+ if ($CGI::MOD_PERL) {
+ if ($CGI::MOD_PERL == 1) {
+ my $r = Apache->request;
+ $r->register_cleanup(\&CGI::Pretty::_reset_globals);
+ }
+ else {
+ my $r = Apache2::RequestUtil->request;
+ $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
+ }
+ }
+ $class->_reset_globals if $CGI::PERLEX;
+
+ return bless $this, $class;
+}
+
+sub initialize_globals {
+ # This is the string used for indentation of tags
+ $CGI::Pretty::INDENT = "\t";
+
+ # This is the string used for seperation between tags
+ $CGI::Pretty::LINEBREAK = $/;
+
+ # These tags are not prettify'd.
+ # When this list is updated, also update the docs.
+ @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
+
+ 1;
+}
+sub _reset_globals { initialize_globals(); }
+
+# ugly, but quick fix
+sub import {
+ my $self = shift;
+ no strict 'refs';
+ ${ "$self\::AutoloadClass" } = 'CGI';
+
+ # This causes modules to clash.
+ undef %CGI::EXPORT;
+ undef %CGI::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"});
+ foreach my $sym (keys %CGI::EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
+ foreach $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+1;
+
+=head1 NAME
+
+CGI::Pretty - module to produce nicely formatted HTML code
+
+=head1 SYNOPSIS
+
+ use CGI::Pretty qw( :html3 );
+
+ # Print a table with a single data element
+ print table( TR( td( "foo" ) ) );
+
+=head1 DESCRIPTION
+
+CGI::Pretty is a module that derives from CGI. It's sole function is to
+allow users of CGI to output nicely formatted HTML code.
+
+When using the CGI module, the following code:
+ print table( TR( td( "foo" ) ) );
+
+produces the following output:
+ <TABLE><TR><TD>foo</TD></TR></TABLE>
+
+If a user were to create a table consisting of many rows and many columns,
+the resultant HTML code would be quite difficult to read since it has no
+carriage returns or indentation.
+
+CGI::Pretty fixes this problem. What it does is add a carriage
+return and indentation to the HTML code so that one can easily read
+it.
+
+ print table( TR( td( "foo" ) ) );
+
+now produces the following output:
+ <TABLE>
+ <TR>
+ <TD>foo</TD>
+ </TR>
+ </TABLE>
+
+=head2 Recommendation for when to use CGI::Pretty
+
+CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
+it could be about 10 times slower. Adding newslines and spaces may alter the
+rendered appearance of HTML. Also, the extra newlines and spaces also make the
+file size larger, making the files take longer to download.
+
+With all those considerations, it is recommended that CGI::Pretty be used
+primarily for debugging.
+
+=head2 Tags that won't be formatted
+
+The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
+If these tags were formatted, the
+user would see the extra indentation on the web browser causing the page to
+look different than what would be expected. If you wish to add more tags to
+the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
+
+ push @CGI::Pretty::AS_IS,qw(XMP);
+
+=head2 Customizing the Indenting
+
+If you wish to have your own personal style of indenting, you can change the
+C<$INDENT> variable:
+
+ $CGI::Pretty::INDENT = "\t\t";
+
+would cause the indents to be two tabs.
+
+Similarly, if you wish to have more space between lines, you may change the
+C<$LINEBREAK> variable:
+
+ $CGI::Pretty::LINEBREAK = "\n\n";
+
+would create two carriage returns between lines.
+
+If you decide you want to use the regular CGI indenting, you can easily do
+the following:
+
+ $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
+
+=head1 AUTHOR
+
+Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
+Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
+distribution.
+
+Copyright 1999, Brian Paulsen. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Bug reports and comments to Brian@ThePaulsens.com. You can also write
+to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
+sure I understand it!
+
+=head1 SEE ALSO
+
+L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CGI/Push.pm b/Master/tlpkg/tlperl/lib/CGI/Push.pm
new file mode 100644
index 00000000000..9e72abda550
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Push.pm
@@ -0,0 +1,325 @@
+package CGI::Push;
+
+# 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-2000, 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::Push::VERSION='1.04';
+use CGI;
+use CGI::Util 'rearrange';
+@ISA = ('CGI');
+
+$CGI::DefaultClass = 'CGI::Push';
+$CGI::Push::AutoloadClass = 'CGI';
+
+# add do_push() and push_delay() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
+
+sub do_push {
+ my ($self,@p) = CGI::self_or_default(@_);
+
+ # unbuffer output
+ $| = 1;
+ srand;
+ my ($random) = sprintf("%08.0f",rand()*1E8);
+ my ($boundary) = "----=_NeXtPaRt$random";
+
+ my (@header);
+ my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ $type = 'text/html' unless $type;
+ $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
+ $delay = 1 unless defined($delay);
+ $self->push_delay($delay);
+ $nph = 1 unless defined($nph);
+
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ push(@o,'-Target'=>$target) if defined($target);
+ push(@o,'-Cookie'=>$cookie) if defined($cookie);
+ push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
+ push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
+ push(@o,'-Status'=>'200 OK');
+ push(@o,'-nph'=>1) if $nph;
+ print $self->header(@o);
+
+ $boundary = "$CGI::CRLF--$boundary";
+
+ print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF";
+
+ my (@contents) = &$callback($self,++$COUNTER);
+
+ # now we enter a little loop
+ while (1) {
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print @contents;
+ @contents = &$callback($self,++$COUNTER);
+ if ((@contents) && defined($contents[0])) {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ } else {
+ if ($last_page && ref($last_page) eq 'CODE') {
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print &$last_page($self,$COUNTER);
+ }
+ print "${boundary}--$CGI::CRLF";
+ last;
+ }
+ }
+ print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF";
+}
+
+sub simple_counter {
+ my ($self,$count) = @_;
+ return $self->start_html("CGI::Push Default Counter"),
+ $self->h1("CGI::Push Default Counter"),
+ "This page has been updated ",$self->strong($count)," times.",
+ $self->hr(),
+ $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
+ $self->end_html;
+}
+
+sub do_sleep {
+ my $delay = shift;
+ if ( ($delay >= 1) && ($delay!~/\./) ){
+ sleep($delay);
+ } else {
+ select(undef,undef,undef,$delay);
+ }
+}
+
+sub push_delay {
+ my ($self,$delay) = CGI::self_or_default(@_);
+ return defined($delay) ? $self->{'.delay'} =
+ $delay : $self->{'.delay'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Push - Simple Interface to Server Push
+
+=head1 SYNOPSIS
+
+ use CGI::Push qw(:standard);
+
+ do_push(-next_page=>\&next_page,
+ -last_page=>\&last_page,
+ -delay=>0.5);
+
+ sub next_page {
+ my($q,$counter) = @_;
+ return undef if $counter >= 10;
+ return start_html('Test'),
+ h1('Visible'),"\n",
+ "This page has been called ", strong($counter)," times",
+ end_html();
+ }
+
+ sub last_page {
+ my($q,$counter) = @_;
+ return start_html('Done'),
+ h1('Finished'),
+ strong($counter - 1),' iterations.',
+ end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Push is a subclass of the CGI object created by CGI.pm. It is
+specialized for server push operations, which allow you to create
+animated pages whose content changes at regular intervals.
+
+You provide CGI::Push with a pointer to a subroutine that will draw
+one page. Every time your subroutine is called, it generates a new
+page. The contents of the page will be transmitted to the browser
+in such a way that it will replace what was there beforehand. The
+technique will work with HTML pages as well as with graphics files,
+allowing you to create animated GIFs.
+
+Only Netscape Navigator supports server push. Internet Explorer
+browsers do not.
+
+=head1 USING CGI::Push
+
+CGI::Push adds one new method to the standard CGI suite, do_push().
+When you call this method, you pass it a reference to a subroutine
+that is responsible for drawing each new page, an interval delay, and
+an optional subroutine for drawing the last page. Other optional
+parameters include most of those recognized by the CGI header()
+method.
+
+You may call do_push() in the object oriented manner or not, as you
+prefer:
+
+ use CGI::Push;
+ $q = new CGI::Push;
+ $q->do_push(-next_page=>\&draw_a_page);
+
+ -or-
+
+ use CGI::Push qw(:standard);
+ do_push(-next_page=>\&draw_a_page);
+
+Parameters are as follows:
+
+=over 4
+
+=item -next_page
+
+ do_push(-next_page=>\&my_draw_routine);
+
+This required parameter points to a reference to a subroutine responsible for
+drawing each new page. The subroutine should expect two parameters
+consisting of the CGI object and a counter indicating the number
+of times the subroutine has been called. It should return the
+contents of the page as an B<array> of one or more items to print.
+It can return a false value (or an empty array) in order to abort the
+redrawing loop and print out the final page (if any)
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 100;
+ return start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You are of course free to refer to create and use global variables
+within your draw routine in order to achieve special effects.
+
+=item -last_page
+
+This optional parameter points to a reference to the subroutine
+responsible for drawing the last page of the series. It is called
+after the -next_page routine returns a false value. The subroutine
+itself should have exactly the same calling conventions as the
+-next_page routine.
+
+=item -type
+
+This optional parameter indicates the content type of each page. It
+defaults to "text/html". Normally the module assumes that each page
+is of a homogenous MIME type. However if you provide either of the
+magic values "heterogeneous" or "dynamic" (the latter provided for the
+convenience of those who hate long parameter names), you can specify
+the MIME type -- and other header fields -- on a per-page basis. See
+"heterogeneous pages" for more details.
+
+=item -delay
+
+This indicates the delay, in seconds, between frames. Smaller delays
+refresh the page faster. Fractional values are allowed.
+
+B<If not specified, -delay will default to 1 second>
+
+=item -cookie, -target, -expires, -nph
+
+These have the same meaning as the like-named parameters in
+CGI::header().
+
+If not specified, -nph will default to 1 (as needed for many servers, see below).
+
+=back
+
+=head2 Heterogeneous Pages
+
+Ordinarily all pages displayed by CGI::Push share a common MIME type.
+However by providing a value of "heterogeneous" or "dynamic" in the
+do_push() -type parameter, you can specify the MIME type of each page
+on a case-by-case basis.
+
+If you use this option, you will be responsible for producing the
+HTTP header for each page. Simply modify your draw routine to
+look like this:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You can add any header fields that you like, but some (cookies and
+status fields included) may not be interpreted by the browser. One
+interesting effect is to display a series of pages, then, after the
+last page, to redirect the browser to a new URL. Because redirect()
+does b<not> work, the easiest way is with a -refresh header field,
+as shown below:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 10;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+ sub my_last_page {
+ return header(-refresh=>'5; URL=http://somewhere.else/finished.html',
+ -type=>'text/html'),
+ start_html('Moved'),
+ h1('This is the last page'),
+ 'Goodbye!'
+ hr,
+ end_html;
+ }
+
+=head2 Changing the Page Delay on the Fly
+
+If you would like to control the delay between pages on a page-by-page
+basis, call push_delay() from within your draw routine. push_delay()
+takes a single numeric argument representing the number of seconds you
+wish to delay after the current page is displayed and before
+displaying the next one. The delay may be fractional. Without
+parameters, push_delay() just returns the current delay.
+
+=head1 INSTALLING CGI::Push SCRIPTS
+
+Server push scripts must be installed as no-parsed-header (NPH)
+scripts in order to work correctly on many servers. On Unix systems,
+this is most often accomplished by prefixing the script's name with "nph-".
+Recognition of NPH scripts happens automatically with WebSTAR and
+Microsoft IIS. Users of other servers should see their documentation
+for help.
+
+Apache web server from version 1.3b2 on does not need server
+push scripts installed as NPH scripts: the -nph parameter to do_push()
+may be set to a false value to disable the extra headers needed by an
+NPH script.
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/CGI/Switch.pm b/Master/tlpkg/tlperl/lib/CGI/Switch.pm
new file mode 100644
index 00000000000..a311080e49f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Switch.pm
@@ -0,0 +1,28 @@
+package CGI::Switch;
+use CGI;
+
+$VERSION = '1.01';
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Switch - Backward compatibility module for defunct CGI::Switch
+
+=head1 SYNOPSIS
+
+Do not use this module. It is deprecated.
+
+=head1 ABSTRACT
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR INFORMATION
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CGI/Util.pm b/Master/tlpkg/tlperl/lib/CGI/Util.pm
new file mode 100644
index 00000000000..eb639e40d59
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI/Util.pm
@@ -0,0 +1,392 @@
+package CGI::Util;
+
+use strict;
+use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
+ expires ebcdic2ascii ascii2ebcdic);
+
+$VERSION = '3.48';
+
+$EBCDIC = "\t" ne "\011";
+# (ord('^') == 95) for codepage 1047 as on os390, vmesa
+@A2E = (
+ 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+ 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+ 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+ 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+ 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+ 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
+ 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+ 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+ 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+ 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+ 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+ );
+@E2A = (
+ 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
+ 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
+ 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
+ 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
+ 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
+ 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
+ 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
+ 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
+ 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
+ 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
+ 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
+ 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
+ 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
+ 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
+ );
+
+if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
+ $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
+ $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
+ $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
+ $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
+ $A2E[249] = 192;
+
+ $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
+ $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
+ $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
+ $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
+ $E2A[255] = 126;
+ }
+elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
+ $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
+ $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
+
+ $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
+ $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
+}
+
+# Smart rearrangement of parameters to allow named parameter
+# calling. We do the rearrangement if:
+# the first parameter begins with a -
+
+sub rearrange {
+ my ($order,@param) = @_;
+ my ($result, $leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
+ if keys %$leftover;
+ @$result;
+}
+
+sub rearrange_header {
+ my ($order,@param) = @_;
+
+ my ($result,$leftover) = _rearrange_params( $order, @param );
+ push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
+
+ @$result;
+}
+
+sub _rearrange_params {
+ my($order,@param) = @_;
+ return [] unless @param;
+
+ if (ref($param[0]) eq 'HASH') {
+ @param = %{$param[0]};
+ } else {
+ return \@param
+ unless (defined($param[0]) && substr($param[0],0,1) eq '-');
+ }
+
+ # map parameters into positional indices
+ my ($i,%pos);
+ $i = 0;
+ foreach (@$order) {
+ foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
+ $i++;
+ }
+
+ my (@result,%leftover);
+ $#result = $#$order; # preextend
+ while (@param) {
+ my $key = lc(shift(@param));
+ $key =~ s/^\-//;
+ if (exists $pos{$key}) {
+ $result[$pos{$key}] = shift(@param);
+ } else {
+ $leftover{$key} = shift(@param);
+ }
+ }
+
+ return \@result, \%leftover;
+}
+
+sub make_attributes {
+ my $attr = shift;
+ return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+ my $escape = shift || 0;
+ my $do_not_quote = shift;
+
+ my $quote = $do_not_quote ? '' : '"';
+
+ my(@att);
+ foreach (keys %{$attr}) {
+ my($key) = $_;
+ $key=~s/^\-//; # get rid of initial - if present
+
+ # old way: breaks EBCDIC!
+ # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
+
+ ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
+
+ my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
+ push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
+ }
+ return @att;
+}
+
+sub simple_escape {
+ return unless defined(my $toencode = shift);
+ $toencode =~ s{&}{&amp;}gso;
+ $toencode =~ s{<}{&lt;}gso;
+ $toencode =~ s{>}{&gt;}gso;
+ $toencode =~ s{\"}{&quot;}gso;
+# Doesn't work. Can't work. forget it.
+# $toencode =~ s{\x8b}{&#139;}gso;
+# $toencode =~ s{\x9b}{&#155;}gso;
+ $toencode;
+}
+
+sub utf8_chr {
+ my $c = shift(@_);
+ if ($] >= 5.006){
+ require utf8;
+ my $u = chr($c);
+ utf8::encode($u); # drop utf8 flag
+ return $u;
+ }
+ if ($c < 0x80) {
+ return sprintf("%c", $c);
+ } elsif ($c < 0x800) {
+ return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
+ } elsif ($c < 0x10000) {
+ return sprintf("%c%c%c",
+ 0xe0 | ($c >> 12),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } elsif ($c < 0x200000) {
+ return sprintf("%c%c%c%c",
+ 0xf0 | ($c >> 18),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } elsif ($c < 0x4000000) {
+ return sprintf("%c%c%c%c%c",
+ 0xf8 | ($c >> 24),
+ 0x80 | (($c >> 18) & 0x3f),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+
+ } elsif ($c < 0x80000000) {
+ return sprintf("%c%c%c%c%c%c",
+ 0xfc | ($c >> 30),
+ 0x80 | (($c >> 24) & 0x3f),
+ 0x80 | (($c >> 18) & 0x3f),
+ 0x80 | (($c >> 12) & 0x3f),
+ 0x80 | (($c >> 6) & 0x3f),
+ 0x80 | ( $c & 0x3f));
+ } else {
+ return utf8_chr(0xfffd);
+ }
+}
+
+# unescape URL-encoded data
+sub unescape {
+ shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $todecode = shift;
+ return undef unless defined($todecode);
+ $todecode =~ tr/+/ /; # pluses become spaces
+ if ($EBCDIC) {
+ $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
+ } else {
+ # handle surrogate pairs first -- dankogai
+ $todecode =~ s{
+ %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+ %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
+ }{
+ utf8_chr(
+ 0x10000
+ + (hex($1) - 0xD800) * 0x400
+ + (hex($2) - 0xDC00)
+ )
+ }gex;
+ $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
+ defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
+ }
+ return $todecode;
+}
+
+# URL-encode data
+#
+# We cannot use the %u escapes, they were rejected by W3C, so the official
+# way is %XX-escaped utf-8 encoding.
+# Naturally, Unicode strings have to be converted to their utf-8 byte
+# representation. (No action is required on 5.6.)
+# Byte strings were traditionally used directly as a sequence of octets.
+# This worked if they actually represented binary data (i.e. in CGI::Compress).
+# This also worked if these byte strings were actually utf-8 encoded; e.g.,
+# when the source file used utf-8 without the apropriate "use utf8;".
+# This fails if the byte string is actually a Latin 1 encoded string, but it
+# was always so and cannot be fixed without breaking the binary data case.
+# -- Stepan Kasal <skasal@redhat.com>
+#
+if ($] == 5.008) {
+ package utf8;
+
+ no warnings 'redefine'; # needed for Perl 5.8.1+
+
+ my $is_utf8_redefinition = <<'EOR';
+ sub is_utf8 {
+ my ($text) = @_;
+
+ my $ctext = pack q{C0a*}, $text;
+
+ return ($text ne $ctext) && ($ctext =~ m/^(
+ [\x09\x0A\x0D\x20-\x7E]
+ | [\xC2-\xDF][\x80-\xBF]
+ | \xE0[\xA0-\xBF][\x80-\xBF]
+ | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}
+ | \xED[\x80-\x9F][\x80-\xBF]
+ | \xF0[\x90-\xBF][\x80-\xBF]{2}
+ | [\xF1-\xF3][\x80-\xBF]{3}
+ | \xF4[\x80-\x8F][\x80-\xBF]{2}
+ )*$/xo);
+ }
+EOR
+
+ eval $is_utf8_redefinition;
+}
+
+sub escape {
+ shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ utf8::encode($toencode) if ($] >= 5.008 && utf8::is_utf8($toencode));
+ if ($EBCDIC) {
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
+ } else {
+ $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
+ }
+ return $toencode;
+}
+
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers. (They differ, unfortunately.)
+# Thanks to Mark Fisher for this.
+sub expires {
+ my($time,$format) = @_;
+ $format ||= 'http';
+
+ my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+ # pass through preformatted dates for the sake of expire_calc()
+ $time = expire_calc($time);
+ return $time unless $time =~ /^\d+$/;
+
+ # make HTTP/cookie date string from GMT'ed time
+ # (cookies use '-' as date separator, HTTP uses ' ')
+ my($sc) = ' ';
+ $sc = '-' if $format eq "cookie";
+ my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+ $year += 1900;
+ return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time. It incorporates modifications from
+# Mark Fisher.
+sub expire_calc {
+ my($time) = @_;
+ my(%mult) = ('s'=>1,
+ 'm'=>60,
+ 'h'=>60*60,
+ 'd'=>60*60*24,
+ 'M'=>60*60*24*30,
+ 'y'=>60*60*24*365);
+ # format for time can be in any of the forms...
+ # "now" -- expire immediately
+ # "+180s" -- in 180 seconds
+ # "+2m" -- in 2 minutes
+ # "+12h" -- in 12 hours
+ # "+1d" -- in 1 day
+ # "+3M" -- in 3 months
+ # "+2y" -- in 2 years
+ # "-3m" -- 3 minutes ago(!)
+ # If you don't supply one of these forms, we assume you are
+ # specifying the date yourself
+ my($offset);
+ if (!$time || (lc($time) eq 'now')) {
+ $offset = 0;
+ } elsif ($time=~/^\d+/) {
+ return $time;
+ } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
+ $offset = ($mult{$2} || 1)*$1;
+ } else {
+ return $time;
+ }
+ return (time+$offset);
+}
+
+sub ebcdic2ascii {
+ my $data = shift;
+ $data =~ s/(.)/chr $E2A[ord($1)]/ge;
+ $data;
+}
+
+sub ascii2ebcdic {
+ my $data = shift;
+ $data =~ s/(.)/chr $A2E[ord($1)]/ge;
+ $data;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Util - Internal utilities used by CGI module
+
+=head1 SYNOPSIS
+
+none
+
+=head1 DESCRIPTION
+
+no public subroutines
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@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 SEE ALSO
+
+L<CGI>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Carp/Heavy.pm b/Master/tlpkg/tlperl/lib/Carp/Heavy.pm
new file mode 100644
index 00000000000..38f95d8a5aa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Carp/Heavy.pm
@@ -0,0 +1,10 @@
+package Carp;
+
+# On one line so MakeMaker will see it.
+use Carp; our $VERSION = $Carp::VERSION;
+
+1;
+
+# Most of the machinery of Carp used to be there.
+# It has been moved in Carp.pm now, but this placeholder remains for
+# the benefit of modules that like to preload Carp::Heavy directly.
diff --git a/Master/tlpkg/tlperl/lib/Class/ISA.pm b/Master/tlpkg/tlperl/lib/Class/ISA.pm
new file mode 100644
index 00000000000..83f47acf6d7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/ISA.pm
@@ -0,0 +1,218 @@
+package Class::ISA;
+require 5;
+use strict;
+use vars qw($Debug $VERSION);
+$VERSION = '0.36';
+$Debug = 0 unless defined $Debug;
+
+use if $] >= 5.011, 'deprecate';
+
+###########################################################################
+
+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__
+
+=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 AND LICENSE
+
+Copyright (c) 1999-2009 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@cpan.org>
+
+=head1 MAINTAINER
+
+Maintained by Steffen Mueller C<smueller@cpan.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Class/Struct.pm b/Master/tlpkg/tlperl/lib/Class/Struct.pm
new file mode 100644
index 00000000000..7a9af54faf8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Class/Struct.pm
@@ -0,0 +1,636 @@
+package Class::Struct;
+
+## See POD after __END__
+
+use 5.006_001;
+
+use strict;
+use warnings::register;
+our(@ISA, @EXPORT, $VERSION);
+
+use Carp;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(struct);
+
+$VERSION = '0.63';
+
+## 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 }
+ else { $print++ }
+}
+
+{
+ package Class::Struct::Tie_ISA;
+
+ sub TIEARRAY {
+ my $class = shift;
+ return bless [], $class;
+ }
+
+ sub STORE {
+ my ($self, $index, $value) = @_;
+ Class::Struct::_subclass_error();
+ }
+
+ sub FETCH {
+ my ($self, $index) = @_;
+ $self->[$index];
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return scalar(@$self);
+ }
+
+ sub DESTROY { }
+}
+
+sub import {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ $self->export_to_level( 1, $self, @EXPORT );
+ } elsif ( @_ == 1 ) {
+ # This is admittedly a little bit silly:
+ # do we ever export anything else than 'struct'...?
+ $self->export_to_level( 1, $self, @_ );
+ } else {
+ goto &struct;
+ }
+}
+
+sub struct {
+
+ # Determine parameter list structure, one of:
+ # struct( class => [ element-list ])
+ # struct( class => { element-list })
+ # struct( element-list )
+ # Latter form assumes current package name as struct name.
+
+ my ($class, @decls);
+ my $base_type = ref $_[1];
+ if ( $base_type eq 'HASH' ) {
+ $class = shift;
+ @decls = %{shift()};
+ _usage_error() if @_;
+ }
+ elsif ( $base_type eq 'ARRAY' ) {
+ $class = shift;
+ @decls = @{shift()};
+ _usage_error() if @_;
+ }
+ else {
+ $base_type = 'ARRAY';
+ $class = (caller())[0];
+ @decls = @_;
+ }
+
+ _usage_error() if @decls % 2 == 1;
+
+ # Ensure we are not, and will not be, a subclass.
+
+ my $isa = do {
+ no strict 'refs';
+ \@{$class . '::ISA'};
+ };
+ _subclass_error() if @$isa;
+ tie @$isa, 'Class::Struct::Tie_ISA';
+
+ # Create constructor.
+
+ croak "function 'new' already defined in package $class"
+ if do { no strict 'refs'; defined &{$class . "::new"} };
+
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my %classes = ();
+ my $got_class = 0;
+ my $out = '';
+
+ $out = "{\n package $class;\n use Carp;\n sub new {\n";
+ $out .= " my (\$class, \%init) = \@_;\n";
+ $out .= " \$class = __PACKAGE__ unless \@_;\n";
+
+ my $cnt = 0;
+ my $idx = 0;
+ my( $cmt, $name, $type, $elem );
+
+ if( $base_type eq 'HASH' ){
+ $out .= " my(\$r) = {};\n";
+ $cmt = '';
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $out .= " my(\$r) = [];\n";
+ }
+ while( $idx < @decls ){
+ $name = $decls[$idx];
+ $type = $decls[$idx+1];
+ push( @methods, $name );
+ if( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ $cmt = " # $name";
+ }
+ if( $type =~ /^\*(.)/ ){
+ $refs{$name}++;
+ $type = $1;
+ }
+ my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
+ 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";
+ $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";
+ $hashes{$name}++;
+ }
+ elsif ( $type eq '$') {
+ $out .= " \$r->$elem = $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 .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
+ $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n";
+ $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
+ $out .= " }\n";
+ $classes{$name} = $type;
+ $got_class = 1;
+ }
+ else{
+ croak "'$type' is not a valid struct element type";
+ }
+ $idx += 2;
+ }
+ $out .= " bless \$r, \$class;\n }\n";
+
+ # Create accessor methods.
+
+ my( $pre, $pst, $sel );
+ $cnt = 0;
+ foreach $name (@methods){
+ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
+ warnings::warnif("function '$name' already defined, overrides struct accessor method");
+ }
+ else {
+ $pre = $pst = $cmt = $sel = '';
+ if( defined $refs{$name} ){
+ $pre = "\\(";
+ $pst = ")";
+ $cmt = " # returns ref";
+ }
+ $out .= " sub $name {$cmt\n my \$r = shift;\n";
+ if( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ }
+ elsif( $base_type eq 'HASH' ){
+ $elem = "{'${class}::$name'}";
+ }
+ if( defined $arrays{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $sel = "->[\$i]";
+ }
+ elsif( defined $hashes{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
+ $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 'Too many args to $name' if \@_ > 1;\n";
+ $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
+ $out .= " }\n";
+ }
+ }
+ $out .= "}\n1;\n";
+
+ print $out if $print;
+ my $result = eval $out;
+ carp $@ if $@;
+}
+
+sub _usage_error {
+ confess "struct usage error";
+}
+
+sub _subclass_error {
+ croak 'struct class cannot be a subclass (@ISA not allowed)';
+}
+
+1; # for require
+
+
+__END__
+
+=head1 NAME
+
+Class::Struct - declare struct-like datatypes as Perl classes
+
+=head1 SYNOPSIS
+
+ use Class::Struct;
+ # declare struct, based on array:
+ struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
+ # declare struct, based on hash:
+ struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
+
+ package CLASS_NAME;
+ use Class::Struct;
+ # declare struct, based on array, implicit class name:
+ struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
+
+ # Declare struct at compile time
+ use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ];
+ use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... };
+
+ # declare struct at compile time, based on array, implicit class name:
+ package CLASS_NAME;
+ use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ;
+
+ package Myobj;
+ use Class::Struct;
+ # declare struct with four types of elements:
+ struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
+
+ $obj = new Myobj; # constructor
+
+ # scalar type accessor:
+ $element_value = $obj->s; # element value
+ $obj->s('new value'); # assign to element
+
+ # array type accessor:
+ $ary_ref = $obj->a; # reference to whole array
+ $ary_element_value = $obj->a(2); # array element value
+ $obj->a(2, 'new value'); # assign to array element
+
+ # hash type accessor:
+ $hash_ref = $obj->h; # reference to whole hash
+ $hash_element_value = $obj->h('x'); # hash element value
+ $obj->h('x', 'new value'); # assign to hash element
+
+ # class type accessor:
+ $element_value = $obj->c; # object reference
+ $obj->c->method(...); # call method of object
+ $obj->c(new My_Other_Class); # assign a new object
+
+=head1 DESCRIPTION
+
+C<Class::Struct> exports a single function, C<struct>.
+Given a list of element names and types, and optionally
+a class name, C<struct> creates a Perl 5 class that implements
+a "struct-like" data structure.
+
+The new class is given a constructor method, C<new>, for creating
+struct objects.
+
+Each element in the struct data has an accessor method, which is
+used to assign to the element and to fetch its value. The
+default accessor can be overridden by declaring a C<sub> of the
+same name in the package. (See Example 2.)
+
+Each element's type can be scalar, array, hash, or class.
+
+=head2 The C<struct()> function
+
+The C<struct> function has three forms of parameter-list.
+
+ struct( CLASS_NAME => [ ELEMENT_LIST ]);
+ struct( CLASS_NAME => { ELEMENT_LIST });
+ struct( ELEMENT_LIST );
+
+The first and second forms explicitly identify the name of the
+class being created. The third form assumes the current package
+name as the class name.
+
+An object of a class created by the first and third forms is
+based on an array, whereas an object of a class created by the
+second form is based on a hash. The array-based forms will be
+somewhat faster and smaller; the hash-based forms are more
+flexible.
+
+The class created by C<struct> must not be a subclass of another
+class other than C<UNIVERSAL>.
+
+It can, however, be used as a superclass for other classes. To facilitate
+this, the generated constructor method uses a two-argument blessing.
+Furthermore, if the class is hash-based, the key of each element is
+prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
+
+A function named C<new> must not be explicitly defined in a class
+created by C<struct>.
+
+The I<ELEMENT_LIST> has the form
+
+ NAME => TYPE, ...
+
+Each name-type pair declares one element of the struct. Each
+element name will be defined as an accessor method unless a
+method by that name is explicitly defined; in the latter case, a
+warning is issued if the warning flag (B<-w>) is set.
+
+=head2 Class Creation at Compile Time
+
+C<Class::Struct> can create your class at compile time. The main reason
+for doing this is obvious, so your class acts like every other class in
+Perl. Creating your class at compile time will make the order of events
+similar to using any other class ( or Perl module ).
+
+There is no significant speed gain between compile time and run time
+class creation, there is just a new, more standard order of events.
+
+=head2 Element Types and Accessor Methods
+
+The four element types -- scalar, array, hash, and class -- are
+represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
+optionally preceded by a C<'*'>.
+
+The accessor method provided by C<struct> for an element depends
+on the declared type of the element.
+
+=over 4
+
+=item Scalar (C<'$'> or C<'*$'>)
+
+The element is a scalar, and by default is initialized to C<undef>
+(but see L<Initializing with new>).
+
+The accessor's argument, if any, is assigned to the element.
+
+If the element type is C<'$'>, the value of the element (after
+assignment) is returned. If the element type is C<'*$'>, a reference
+to the element is returned.
+
+=item Array (C<'@'> or C<'*@'>)
+
+The element is an array, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole array (whether or not the element was
+specified as C<'@'> or C<'*@'>).
+
+With one or two arguments, the first argument is an index
+specifying one element of the array; the second argument, if
+present, is assigned to the array element. If the element type
+is C<'@'>, the accessor returns the array element value. If the
+element type is C<'*@'>, a reference to the array element is
+returned.
+
+As a special case, when the accessor is called with an array reference
+as the sole argument, this causes an assignment of the whole array element.
+The object reference is returned.
+
+=item Hash (C<'%'> or C<'*%'>)
+
+The element is a hash, initialized by default to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole hash (whether or not the element was
+specified as C<'%'> or C<'*%'>).
+
+With one or two arguments, the first argument is a key specifying
+one element of the hash; the second argument, if present, is
+assigned to the hash element. If the element type is C<'%'>, the
+accessor returns the hash element value. If the element type is
+C<'*%'>, a reference to the hash element is returned.
+
+As a special case, when the accessor is called with a hash reference
+as the sole argument, this causes an assignment of the whole hash element.
+The object reference is returned.
+
+=item Class (C<'Class_Name'> or C<'*Class_Name'>)
+
+The element's value must be a reference blessed to the named
+class or to one of its subclasses. The element is not initialized
+by default.
+
+The accessor's argument, if any, is assigned to the element. The
+accessor will C<croak> if this is not an appropriate object
+reference.
+
+If the element type does not start with a C<'*'>, the accessor
+returns the element value (after assignment). If the element type
+starts with a C<'*'>, a reference to the element itself is returned.
+
+=back
+
+=head2 Initializing with C<new>
+
+C<struct> always creates a constructor called C<new>. That constructor
+may take a list of initializers for the various elements of the new
+struct.
+
+Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
+The initializer value for a scalar element is just a scalar value. The
+initializer for an array element is an array reference. The initializer
+for a hash is a hash reference.
+
+The initializer for a class element is an object of the corresponding class,
+or of one of it's subclasses, or a reference to a hash containing named
+arguments to be passed to the element's constructor.
+
+See Example 3 below for an example of initialization.
+
+=head1 EXAMPLES
+
+=over 4
+
+=item Example 1
+
+Giving a struct element a class type that is also a struct is how
+structs are nested. Here, C<Timeval> represents a time (seconds and
+microseconds), and C<Rusage> has two elements, each of which is of
+type C<Timeval>.
+
+ use Class::Struct;
+
+ struct( Rusage => {
+ ru_utime => 'Timeval', # user time used
+ ru_stime => 'Timeval', # system time used
+ });
+
+ struct( Timeval => [
+ tv_secs => '$', # seconds
+ tv_usecs => '$', # microseconds
+ ]);
+
+ # create an object:
+ my $t = Rusage->new(ru_utime=>Timeval->new(), ru_stime=>Timeval->new());
+
+ # $t->ru_utime and $t->ru_stime are objects of type Timeval.
+ # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
+ $t->ru_utime->tv_secs(100);
+ $t->ru_utime->tv_usecs(0);
+ $t->ru_stime->tv_secs(5);
+ $t->ru_stime->tv_usecs(0);
+
+=item Example 2
+
+An accessor function can be redefined in order to provide
+additional checking of values, etc. Here, we want the C<count>
+element always to be nonnegative, so we redefine the C<count>
+accessor accordingly.
+
+ package MyObj;
+ use Class::Struct;
+
+ # declare the struct
+ struct ( 'MyObj', { count => '$', stuff => '%' } );
+
+ # override the default accessor method for 'count'
+ sub count {
+ my $self = shift;
+ if ( @_ ) {
+ die 'count must be nonnegative' if $_[0] < 0;
+ $self->{'MyObj::count'} = shift;
+ warn "Too many args to count" if @_;
+ }
+ return $self->{'MyObj::count'};
+ }
+
+ package main;
+ $x = new MyObj;
+ print "\$x->count(5) = ", $x->count(5), "\n";
+ # prints '$x->count(5) = 5'
+
+ print "\$x->count = ", $x->count, "\n";
+ # prints '$x->count = 5'
+
+ print "\$x->count(-5) = ", $x->count(-5), "\n";
+ # dies due to negative argument!
+
+=item Example 3
+
+The constructor of a generated class can be passed a list
+of I<element>=>I<value> pairs, with which to initialize the struct.
+If no initializer is specified for a particular element, its default
+initialization is performed instead. Initializers for non-existent
+elements are silently ignored.
+
+Note that the initializer for a nested class may be specified as
+an object of that class, or as a reference to a hash of initializers
+that are passed on to the nested struct's constructor.
+
+ use Class::Struct;
+
+ struct Breed =>
+ {
+ name => '$',
+ cross => '$',
+ };
+
+ struct Cat =>
+ [
+ name => '$',
+ kittens => '@',
+ markings => '%',
+ breed => 'Breed',
+ ];
+
+
+ my $cat = Cat->new( name => 'Socks',
+ kittens => ['Monica', 'Kenneth'],
+ markings => { socks=>1, blaze=>"white" },
+ breed => Breed->new(name=>'short-hair', cross=>1),
+ or: breed => {name=>'short-hair', cross=>1},
+ );
+
+ print "Once a cat called ", $cat->name, "\n";
+ print "(which was a ", $cat->breed->name, ")\n";
+ print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";
+
+=back
+
+=head1 Author and Modification History
+
+Modified by Damian Conway, 2001-09-10, v0.62.
+
+ Modified implicit construction of nested objects.
+ Now will also take an object ref instead of requiring a hash ref.
+ Also default initializes nested object attributes to undef, rather
+ than calling object constructor without args
+ Original over-helpfulness was fraught with problems:
+ * the class's constructor might not be called 'new'
+ * the class might not have a hash-like-arguments constructor
+ * the class might not have a no-argument constructor
+ * "recursive" data structures didn't work well:
+ package Person;
+ struct { mother => 'Person', father => 'Person'};
+
+
+Modified by Casey West, 2000-11-08, v0.59.
+
+ Added the ability for compile time class creation.
+
+Modified by Damian Conway, 1999-03-05, v0.58.
+
+ Added handling of hash-like arg list to class ctor.
+
+ Changed to two-argument blessing in ctor to support
+ derivation from created classes.
+
+ Added classname prefixes to keys in hash-based classes
+ (refer to "Perl Cookbook", Recipe 13.12 for rationale).
+
+ Corrected behaviour of accessors for '*@' and '*%' struct
+ elements. Package now implements documented behaviour when
+ returning a reference to an entire hash or array element.
+ Previously these were returned as a reference to a reference
+ to the element.
+
+Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
+
+ members() function removed.
+ Documentation corrected and extended.
+ Use of struct() in a subclass prohibited.
+ User definition of accessor allowed.
+ Treatment of '*' in element types corrected.
+ Treatment of classes as element types corrected.
+ Class name to struct() made optional.
+ Diagnostic checks added.
+
+Originally C<Class::Template> by Dean Roehrich.
+
+ # Template.pm --- struct/member template builder
+ # 12mar95
+ # Dean Roehrich
+ #
+ # changes/bugs fixed since 28nov94 version:
+ # - podified
+ # changes/bugs fixed since 21nov94 version:
+ # - Fixed examples.
+ # changes/bugs fixed since 02sep94 version:
+ # - Moved to Class::Template.
+ # changes/bugs fixed since 20feb94 version:
+ # - Updated to be a more proper module.
+ # - Added "use strict".
+ # - Bug in build_methods, was using @var when @$var needed.
+ # - Now using my() rather than local().
+ #
+ # Uses perl5 classes to create nested data types.
+ # This is offered as one implementation of Tom Christiansen's "structs.pl"
+ # idea.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm b/Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm
new file mode 100644
index 00000000000..48f82073355
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm
@@ -0,0 +1,355 @@
+
+package Compress::Raw::Bzip2;
+
+use strict ;
+use warnings ;
+
+require 5.004 ;
+require Exporter;
+use AutoLoader;
+use Carp ;
+
+use bytes ;
+our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD);
+
+$VERSION = '2.024';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+@ISA = qw(Exporter);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ BZ_RUN
+ BZ_FLUSH
+ BZ_FINISH
+
+ BZ_OK
+ BZ_RUN_OK
+ BZ_FLUSH_OK
+ BZ_FINISH_OK
+ BZ_STREAM_END
+ BZ_SEQUENCE_ERROR
+ BZ_PARAM_ERROR
+ BZ_MEM_ERROR
+ BZ_DATA_ERROR
+ BZ_DATA_ERROR_MAGIC
+ BZ_IO_ERROR
+ BZ_UNEXPECTED_EOF
+ BZ_OUTBUFF_FULL
+ BZ_CONFIG_ERROR
+
+ );
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+
+}
+
+use constant FLAG_APPEND => 1 ;
+use constant FLAG_CRC => 2 ;
+use constant FLAG_ADLER => 4 ;
+use constant FLAG_CONSUME_INPUT => 8 ;
+
+eval {
+ require XSLoader;
+ XSLoader::load('Compress::Raw::Bzip2', $XS_VERSION);
+ 1;
+}
+or do {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap Compress::Raw::Bzip2 $XS_VERSION ;
+};
+
+#sub Compress::Raw::Bzip2::new
+#{
+# my $class = shift ;
+# my ($ptr, $status) = _new(@_);
+# return wantarray ? (undef, $status) : undef
+# unless $ptr ;
+# my $obj = bless [$ptr], $class ;
+# return wantarray ? ($obj, $status) : $obj;
+#}
+#
+#package Compress::Raw::Bunzip2 ;
+#
+#sub Compress::Raw::Bunzip2::new
+#{
+# my $class = shift ;
+# my ($ptr, $status) = _new(@_);
+# return wantarray ? (undef, $status) : undef
+# unless $ptr ;
+# my $obj = bless [$ptr], $class ;
+# return wantarray ? ($obj, $status) : $obj;
+#}
+
+package Compress::Raw::Bzip2;
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Compress::Raw::Bzip2 - Low-Level Interface to bzip2 compression library
+
+=head1 SYNOPSIS
+
+ use Compress::Raw::Bzip2 ;
+
+ my ($bz, $status) = new Compress::Raw::Bzip2 [OPTS]
+ or die "Cannot create bzip2 object: $bzerno\n";
+
+ $status = $bz->bzdeflate($input, $output);
+ $status = $bz->bzflush($output);
+ $status = $bz->bzclose($output);
+
+ my ($bz, $status) = new Compress::Raw::Bunzip2 [OPTS]
+ or die "Cannot create bunzip2 object: $bzerno\n";
+
+ $status = $bz->bzinflate($input, $output);
+
+ my $version = Compress::Raw::Bzip2::bzlibversion();
+
+=head1 DESCRIPTION
+
+C<Compress::Raw::Bzip2> provides an interface to the in-memory
+compression/uncompression functions from the bzip2 compression library.
+
+Although the primary purpose for the existence of C<Compress::Raw::Bzip2>
+is for use by the C<IO::Compress::Bzip2> and C<IO::Compress::Bunzip2>
+modules, it can be used on its own for simple compression/uncompression
+tasks.
+
+=head1 Compression
+
+=head2 ($z, $status) = new Compress::Raw::Bzip2 $appendOutput, $blockSize100k, $workfactor;
+
+Creates a new compression object.
+
+If successful, it will return the initialised compression object, C<$z>
+and a C<$status> of C<BZ_OK> in a list context. In scalar context it
+returns the deflation object, C<$z>, only.
+
+If not successful, the returned compression object, C<$z>, will be
+I<undef> and C<$status> will hold the a I<bzip2> error code.
+
+Below is a list of the valid options:
+
+=over 5
+
+=item B<$appendOutput>
+
+Controls whether the compressed data is appended to the output buffer in
+the C<bzdeflate>, C<bzflush> and C<bzclose> methods.
+
+Defaults to 1.
+
+=item B<$blockSize100k>
+
+To quote the bzip2 documentation
+
+ blockSize100k specifies the block size to be used for compression. It
+ should be a value between 1 and 9 inclusive, and the actual block size
+ used is 100000 x this figure. 9 gives the best compression but takes
+ most memory.
+
+Defaults to 1.
+
+=item B<$workfactor>
+
+To quote the bzip2 documentation
+
+ This parameter controls how the compression phase behaves when
+ presented with worst case, highly repetitive, input data. If
+ compression runs into difficulties caused by repetitive data, the
+ library switches from the standard sorting algorithm to a fallback
+ algorithm. The fallback is slower than the standard algorithm by
+ perhaps a factor of three, but always behaves reasonably, no matter how
+ bad the input.
+
+ Lower values of workFactor reduce the amount of effort the standard
+ algorithm will expend before resorting to the fallback. You should set
+ this parameter carefully; too low, and many inputs will be handled by
+ the fallback algorithm and so compress rather slowly, too high, and
+ your average-to-worst case compression times can become very large. The
+ default value of 30 gives reasonable behaviour over a wide range of
+ circumstances.
+
+ Allowable values range from 0 to 250 inclusive. 0 is a special case,
+ equivalent to using the default value of 30.
+
+Defaults to 0.
+
+=back
+
+=head2 $status = $bz->bzdeflate($input, $output);
+
+Reads the contents of C<$input>, compresses it and writes the compressed
+data to C<$output>.
+
+Returns C<BZ_RUN_OK> on success and a C<bzip2> error code on failure.
+
+If C<appendOutput> is enabled in the constructor for the bzip2 object, the
+compressed data will be appended to C<$output>. If not enabled, C<$output>
+will be truncated before the compressed data is written to it.
+
+=head2 $status = $bz->bzflush($output);
+
+Flushes any pending compressed data to C<$output>.
+
+Returns C<BZ_RUN_OK> on success and a C<bzip2> error code on failure.
+
+=head2 $status = $bz->bzclose($output);
+
+Terminates the compressed data stream and flushes any pending compressed
+data to C<$output>.
+
+Returns C<BZ_STREAM_END> on success and a C<bzip2> error code on failure.
+
+=head2 Example
+
+=head1 Uncompression
+
+=head2 ($z, $status) = new Compress::Raw::Bunzip2 $appendOutput, $consumeInput, $small, $limitOutput;
+
+If successful, it will return the initialised uncompression object, C<$z>
+and a C<$status> of C<BZ_OK> in a list context. In scalar context it
+returns the deflation object, C<$z>, only.
+
+If not successful, the returned uncompression object, C<$z>, will be
+I<undef> and C<$status> will hold the a I<bzip2> error code.
+
+Below is a list of the valid options:
+
+=over 5
+
+=item B<$appendOutput>
+
+Controls whether the compressed data is appended to the output buffer in the
+C<bzinflate>, C<bzflush> and C<bzclose> methods.
+
+Defaults to 1.
+
+=item B<$consumeInput>
+
+=item B<$small>
+
+To quote the bzip2 documentation
+
+ If small is nonzero, the library will use an alternative decompression
+ algorithm which uses less memory but at the cost of decompressing more
+ slowly (roughly speaking, half the speed, but the maximum memory
+ requirement drops to around 2300k).
+
+Defaults to 0.
+
+=item B<$limitOutput>
+
+The C<LimitOutput> option changes the behavior of the C<< $i->bzinflate >>
+method so that the amount of memory used by the output buffer can be
+limited.
+
+When C<LimitOutput> is used the size of the output buffer used will either
+be the 16k or the amount of memory already allocated to C<$output>,
+whichever is larger. Predicting the output size available is tricky, so
+don't rely on getting an exact output buffer size.
+
+When C<LimitOutout> is not specified C<< $i->bzinflate >> will use as much
+memory as it takes to write all the uncompressed data it creates by
+uncompressing the input buffer.
+
+If C<LimitOutput> is enabled, the C<ConsumeInput> option will also be
+enabled.
+
+This option defaults to false.
+
+=back
+
+=head2 $status = $z->bzinflate($input, $output);
+
+Uncompresses C<$input> and writes the uncompressed data to C<$output>.
+
+Returns C<BZ_OK> if the uncompression was successful, but the end of the
+compressed data stream has not been reached. Returns C<BZ_STREAM_END> on
+successful uncompression and the end of the compression stream has been
+reached.
+
+If C<consumeInput> is enabled in the constructor for the bunzip2 object,
+C<$input> will have all compressed data removed from it after
+uncompression. On C<BZ_OK> return this will mean that C<$input> will be an
+empty string; when C<BZ_STREAM_END> C<$input> will either be an empty
+string or will contain whatever data immediately followed the compressed
+data stream.
+
+If C<appendOutput> is enabled in the constructor for the bunzip2 object,
+the uncompressed data will be appended to C<$output>. If not enabled,
+C<$output> will be truncated before the uncompressed data is written to it.
+
+=head1 Misc
+
+=head2 my $version = Compress::Raw::Bzip2::bzlibversion();
+
+Returns the version of the underlying bzip2 library.
+
+=head1 Constants
+
+The following bzip2 constants are exported by this module
+
+ BZ_RUN
+ BZ_FLUSH
+ BZ_FINISH
+
+ BZ_OK
+ BZ_RUN_OK
+ BZ_FLUSH_OK
+ BZ_FINISH_OK
+ BZ_STREAM_END
+ BZ_SEQUENCE_ERROR
+ BZ_PARAM_ERROR
+ BZ_MEM_ERROR
+ BZ_DATA_ERROR
+ BZ_DATA_ERROR_MAGIC
+ BZ_IO_ERROR
+ BZ_UNEXPECTED_EOF
+ BZ_OUTBUFF_FULL
+ BZ_CONFIG_ERROR
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+The primary site for the bzip2 program is F<http://www.bzip.org>.
+
+See the module L<Compress::Bzip2|Compress::Bzip2>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm b/Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm
new file mode 100644
index 00000000000..79c96b76ccd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm
@@ -0,0 +1,1419 @@
+
+package Compress::Raw::Zlib;
+
+require 5.004 ;
+require Exporter;
+use AutoLoader;
+use Carp ;
+
+#use Parse::Parameters;
+
+use strict ;
+use warnings ;
+use bytes ;
+our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD);
+
+$VERSION = '2.024';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+@ISA = qw(Exporter);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ adler32 crc32
+
+ ZLIB_VERSION
+ ZLIB_VERNUM
+
+ DEF_WBITS
+ OS_CODE
+
+ MAX_MEM_LEVEL
+ MAX_WBITS
+
+ Z_ASCII
+ Z_BEST_COMPRESSION
+ Z_BEST_SPEED
+ Z_BINARY
+ Z_BLOCK
+ Z_BUF_ERROR
+ Z_DATA_ERROR
+ Z_DEFAULT_COMPRESSION
+ Z_DEFAULT_STRATEGY
+ Z_DEFLATED
+ Z_ERRNO
+ Z_FILTERED
+ Z_FIXED
+ Z_FINISH
+ Z_FULL_FLUSH
+ Z_HUFFMAN_ONLY
+ Z_MEM_ERROR
+ Z_NEED_DICT
+ Z_NO_COMPRESSION
+ Z_NO_FLUSH
+ Z_NULL
+ Z_OK
+ Z_PARTIAL_FLUSH
+ Z_RLE
+ Z_STREAM_END
+ Z_STREAM_ERROR
+ Z_SYNC_FLUSH
+ Z_UNKNOWN
+ Z_VERSION_ERROR
+
+ WANT_GZIP
+ WANT_GZIP_OR_ZLIB
+);
+
+use constant WANT_GZIP => 16;
+use constant WANT_GZIP_OR_ZLIB => 32;
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+use constant FLAG_APPEND => 1 ;
+use constant FLAG_CRC => 2 ;
+use constant FLAG_ADLER => 4 ;
+use constant FLAG_CONSUME_INPUT => 8 ;
+use constant FLAG_LIMIT_OUTPUT => 16 ;
+
+eval {
+ require XSLoader;
+ XSLoader::load('Compress::Raw::Zlib', $XS_VERSION);
+ 1;
+}
+or do {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap Compress::Raw::Zlib $XS_VERSION ;
+};
+
+
+use constant Parse_any => 0x01;
+use constant Parse_unsigned => 0x02;
+use constant Parse_signed => 0x04;
+use constant Parse_boolean => 0x08;
+use constant Parse_string => 0x10;
+use constant Parse_custom => 0x12;
+
+use constant Parse_store_ref => 0x100 ;
+
+use constant OFF_PARSED => 0 ;
+use constant OFF_TYPE => 1 ;
+use constant OFF_DEFAULT => 2 ;
+use constant OFF_FIXED => 3 ;
+use constant OFF_FIRST_ONLY => 4 ;
+use constant OFF_STICKY => 5 ;
+
+
+
+sub ParseParameters
+{
+ my $level = shift || 0 ;
+
+ my $sub = (caller($level + 1))[3] ;
+ #local $Carp::CarpLevel = 1 ;
+ my $p = new Compress::Raw::Zlib::Parameters() ;
+ $p->parse(@_)
+ or croak "$sub: $p->{Error}" ;
+
+ return $p;
+}
+
+
+sub Compress::Raw::Zlib::Parameters::new
+{
+ my $class = shift ;
+
+ my $obj = { Error => '',
+ Got => {},
+ } ;
+
+ #return bless $obj, ref($class) || $class || __PACKAGE__ ;
+ return bless $obj, 'Compress::Raw::Zlib::Parameters' ;
+}
+
+sub Compress::Raw::Zlib::Parameters::setError
+{
+ my $self = shift ;
+ my $error = shift ;
+ my $retval = @_ ? shift : undef ;
+
+ $self->{Error} = $error ;
+ return $retval;
+}
+
+#sub getError
+#{
+# my $self = shift ;
+# return $self->{Error} ;
+#}
+
+sub Compress::Raw::Zlib::Parameters::parse
+{
+ my $self = shift ;
+
+ my $default = shift ;
+
+ my $got = $self->{Got} ;
+ my $firstTime = keys %{ $got } == 0 ;
+
+ my (@Bad) ;
+ my @entered = () ;
+
+ # Allow the options to be passed as a hash reference or
+ # as the complete hash.
+ if (@_ == 0) {
+ @entered = () ;
+ }
+ elsif (@_ == 1) {
+ my $href = $_[0] ;
+ return $self->setError("Expected even number of parameters, got 1")
+ if ! defined $href or ! ref $href or ref $href ne "HASH" ;
+
+ foreach my $key (keys %$href) {
+ push @entered, $key ;
+ push @entered, \$href->{$key} ;
+ }
+ }
+ else {
+ my $count = @_;
+ return $self->setError("Expected even number of parameters, got $count")
+ if $count % 2 != 0 ;
+
+ for my $i (0.. $count / 2 - 1) {
+ push @entered, $_[2* $i] ;
+ push @entered, \$_[2* $i+1] ;
+ }
+ }
+
+
+ while (my ($key, $v) = each %$default)
+ {
+ croak "need 4 params [@$v]"
+ if @$v != 4 ;
+
+ my ($first_only, $sticky, $type, $value) = @$v ;
+ my $x ;
+ $self->_checkType($key, \$value, $type, 0, \$x)
+ or return undef ;
+
+ $key = lc $key;
+
+ if ($firstTime || ! $sticky) {
+ $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+ }
+
+ $got->{$key}[OFF_PARSED] = 0 ;
+ }
+
+ for my $i (0.. @entered / 2 - 1) {
+ my $key = $entered[2* $i] ;
+ my $value = $entered[2* $i+1] ;
+
+ #print "Key [$key] Value [$value]" ;
+ #print defined $$value ? "[$$value]\n" : "[undef]\n";
+
+ $key =~ s/^-// ;
+ my $canonkey = lc $key;
+
+ if ($got->{$canonkey} && ($firstTime ||
+ ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
+ {
+ my $type = $got->{$canonkey}[OFF_TYPE] ;
+ my $s ;
+ $self->_checkType($key, $value, $type, 1, \$s)
+ or return undef ;
+ #$value = $$value unless $type & Parse_store_ref ;
+ $value = $$value ;
+ $got->{$canonkey} = [1, $type, $value, $s] ;
+ }
+ else
+ { push (@Bad, $key) }
+ }
+
+ if (@Bad) {
+ my ($bad) = join(", ", @Bad) ;
+ return $self->setError("unknown key value(s) @Bad") ;
+ }
+
+ return 1;
+}
+
+sub Compress::Raw::Zlib::Parameters::_checkType
+{
+ my $self = shift ;
+
+ my $key = shift ;
+ my $value = shift ;
+ my $type = shift ;
+ my $validate = shift ;
+ my $output = shift;
+
+ #local $Carp::CarpLevel = $level ;
+ #print "PARSE $type $key $value $validate $sub\n" ;
+ if ( $type & Parse_store_ref)
+ {
+ #$value = $$value
+ # if ref ${ $value } ;
+
+ $$output = $value ;
+ return 1;
+ }
+
+ $value = $$value ;
+
+ if ($type & Parse_any)
+ {
+ $$output = $value ;
+ return 1;
+ }
+ elsif ($type & Parse_unsigned)
+ {
+ return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
+ if $validate && ! defined $value ;
+ return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
+ if $validate && $value !~ /^\d+$/;
+
+ $$output = defined $value ? $value : 0 ;
+ return 1;
+ }
+ elsif ($type & Parse_signed)
+ {
+ return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
+ if $validate && ! defined $value ;
+ return $self->setError("Parameter '$key' must be a signed int, got '$value'")
+ if $validate && $value !~ /^-?\d+$/;
+
+ $$output = defined $value ? $value : 0 ;
+ return 1 ;
+ }
+ elsif ($type & Parse_boolean)
+ {
+ return $self->setError("Parameter '$key' must be an int, got '$value'")
+ if $validate && defined $value && $value !~ /^\d*$/;
+ $$output = defined $value ? $value != 0 : 0 ;
+ return 1;
+ }
+ elsif ($type & Parse_string)
+ {
+ $$output = defined $value ? $value : "" ;
+ return 1;
+ }
+
+ $$output = $value ;
+ return 1;
+}
+
+
+
+sub Compress::Raw::Zlib::Parameters::parsed
+{
+ my $self = shift ;
+ my $name = shift ;
+
+ return $self->{Got}{lc $name}[OFF_PARSED] ;
+}
+
+sub Compress::Raw::Zlib::Parameters::value
+{
+ my $self = shift ;
+ my $name = shift ;
+
+ if (@_)
+ {
+ $self->{Got}{lc $name}[OFF_PARSED] = 1;
+ $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
+ $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
+ }
+
+ return $self->{Got}{lc $name}[OFF_FIXED] ;
+}
+
+sub Compress::Raw::Zlib::Deflate::new
+{
+ my $pkg = shift ;
+ my ($got) = ParseParameters(0,
+ {
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
+ }, @_) ;
+
+
+ croak "Compress::Raw::Zlib::Deflate::new: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $flags = 0 ;
+ $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
+ $flags |= FLAG_CRC if $got->value('CRC32') ;
+ $flags |= FLAG_ADLER if $got->value('ADLER32') ;
+
+ my $windowBits = $got->value('WindowBits');
+ $windowBits += MAX_WBITS()
+ if ($windowBits & MAX_WBITS()) == 0 ;
+
+ _deflateInit($flags,
+ $got->value('Level'),
+ $got->value('Method'),
+ $windowBits,
+ $got->value('MemLevel'),
+ $got->value('Strategy'),
+ $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
+
+}
+
+sub Compress::Raw::Zlib::Inflate::new
+{
+ my $pkg = shift ;
+ my ($got) = ParseParameters(0,
+ {
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'LimitOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'ConsumeInput' => [1, 1, Parse_boolean, 1],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
+ }, @_) ;
+
+
+ croak "Compress::Raw::Zlib::Inflate::new: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $flags = 0 ;
+ $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
+ $flags |= FLAG_CRC if $got->value('CRC32') ;
+ $flags |= FLAG_ADLER if $got->value('ADLER32') ;
+ $flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ;
+ $flags |= FLAG_LIMIT_OUTPUT if $got->value('LimitOutput') ;
+
+
+ my $windowBits = $got->value('WindowBits');
+ $windowBits += MAX_WBITS()
+ if ($windowBits & MAX_WBITS()) == 0 ;
+
+ _inflateInit($flags, $windowBits, $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
+}
+
+sub Compress::Raw::Zlib::InflateScan::new
+{
+ my $pkg = shift ;
+ my ($got) = ParseParameters(0,
+ {
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+
+ 'WindowBits' => [1, 1, Parse_signed, -MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
+ }, @_) ;
+
+
+ croak "Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $flags = 0 ;
+ #$flags |= FLAG_APPEND if $got->value('AppendOutput') ;
+ $flags |= FLAG_CRC if $got->value('CRC32') ;
+ $flags |= FLAG_ADLER if $got->value('ADLER32') ;
+ #$flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ;
+
+ _inflateScanInit($flags, $got->value('WindowBits'), $got->value('Bufsize'),
+ '') ;
+}
+
+sub Compress::Raw::Zlib::inflateScanStream::createDeflateStream
+{
+ my $pkg = shift ;
+ my ($got) = ParseParameters(0,
+ {
+ 'AppendOutput' => [1, 1, Parse_boolean, 0],
+ 'CRC32' => [1, 1, Parse_boolean, 0],
+ 'ADLER32' => [1, 1, Parse_boolean, 0],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, - MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ }, @_) ;
+
+ croak "Compress::Raw::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $flags = 0 ;
+ $flags |= FLAG_APPEND if $got->value('AppendOutput') ;
+ $flags |= FLAG_CRC if $got->value('CRC32') ;
+ $flags |= FLAG_ADLER if $got->value('ADLER32') ;
+
+ $pkg->_createDeflateStream($flags,
+ $got->value('Level'),
+ $got->value('Method'),
+ $got->value('WindowBits'),
+ $got->value('MemLevel'),
+ $got->value('Strategy'),
+ $got->value('Bufsize'),
+ ) ;
+
+}
+
+sub Compress::Raw::Zlib::inflateScanStream::inflate
+{
+ my $self = shift ;
+ my $buffer = $_[1];
+ my $eof = $_[2];
+
+ my $status = $self->scan(@_);
+
+ if ($status == Z_OK() && $_[2]) {
+ my $byte = ' ';
+
+ $status = $self->scan(\$byte, $_[1]) ;
+ }
+
+ return $status ;
+}
+
+sub Compress::Raw::Zlib::deflateStream::deflateParams
+{
+ my $self = shift ;
+ my ($got) = ParseParameters(0, {
+ 'Level' => [1, 1, Parse_signed, undef],
+ 'Strategy' => [1, 1, Parse_unsigned, undef],
+ 'Bufsize' => [1, 1, Parse_unsigned, undef],
+ },
+ @_) ;
+
+ croak "Compress::Raw::Zlib::deflateParams needs Level and/or Strategy"
+ unless $got->parsed('Level') + $got->parsed('Strategy') +
+ $got->parsed('Bufsize');
+
+ croak "Compress::Raw::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ if $got->parsed('Bufsize') && $got->value('Bufsize') <= 1;
+
+ my $flags = 0;
+ $flags |= 1 if $got->parsed('Level') ;
+ $flags |= 2 if $got->parsed('Strategy') ;
+ $flags |= 4 if $got->parsed('Bufsize') ;
+
+ $self->_deflateParams($flags, $got->value('Level'),
+ $got->value('Strategy'), $got->value('Bufsize'));
+
+}
+
+
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+__END__
+
+
+=head1 NAME
+
+Compress::Raw::Zlib - Low-Level Interface to zlib compression library
+
+=head1 SYNOPSIS
+
+ use Compress::Raw::Zlib ;
+
+ ($d, $status) = new Compress::Raw::Zlib::Deflate( [OPT] ) ;
+ $status = $d->deflate($input, $output) ;
+ $status = $d->flush($output [, $flush_type]) ;
+ $d->deflateReset() ;
+ $d->deflateParams(OPTS) ;
+ $d->deflateTune(OPTS) ;
+ $d->dict_adler() ;
+ $d->crc32() ;
+ $d->adler32() ;
+ $d->total_in() ;
+ $d->total_out() ;
+ $d->msg() ;
+ $d->get_Strategy();
+ $d->get_Level();
+ $d->get_BufSize();
+
+ ($i, $status) = new Compress::Raw::Zlib::Inflate( [OPT] ) ;
+ $status = $i->inflate($input, $output [, $eof]) ;
+ $status = $i->inflateSync($input) ;
+ $i->dict_adler() ;
+ $d->crc32() ;
+ $d->adler32() ;
+ $i->total_in() ;
+ $i->total_out() ;
+ $i->msg() ;
+ $d->get_BufSize();
+
+ $crc = adler32($buffer [,$crc]) ;
+ $crc = crc32($buffer [,$crc]) ;
+
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
+
+ my $version = Compress::Raw::Zlib::zlib_version();
+
+=head1 DESCRIPTION
+
+The I<Compress::Raw::Zlib> module provides a Perl interface to the I<zlib>
+compression library (see L</AUTHOR> for details about where to get
+I<zlib>).
+
+=head1 Compress::Raw::Zlib::Deflate
+
+This section defines an interface that allows in-memory compression using
+the I<deflate> interface provided by zlib.
+
+Here is a definition of the interface available:
+
+=head2 B<($d, $status) = new Compress::Raw::Zlib::Deflate( [OPT] ) >
+
+Initialises a deflation object.
+
+If you are familiar with the I<zlib> library, it combines the
+features of the I<zlib> functions C<deflateInit>, C<deflateInit2>
+and C<deflateSetDictionary>.
+
+If successful, it will return the initialised deflation object, C<$d>
+and a C<$status> of C<Z_OK> in a list context. In scalar context it
+returns the deflation object, C<$d>, only.
+
+If not successful, the returned deflation object, C<$d>, will be
+I<undef> and C<$status> will hold the a I<zlib> error code.
+
+The function optionally takes a number of named options specified as
+C<< Name => value >> pairs. This allows individual options to be
+tailored without having to specify them all in the parameter list.
+
+For backward compatibility, it is also possible to pass the parameters
+as a reference to a hash containing the name=>value pairs.
+
+Below is a list of the valid options:
+
+=over 5
+
+=item B<-Level>
+
+Defines the compression level. Valid values are 0 through 9,
+C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and
+C<Z_DEFAULT_COMPRESSION>.
+
+The default is C<Z_DEFAULT_COMPRESSION>.
+
+=item B<-Method>
+
+Defines the compression method. The only valid value at present (and
+the default) is Z_DEFLATED.
+
+=item B<-WindowBits>
+
+To compress an RFC 1950 data stream, set C<WindowBits> to a positive
+number between 8 and 15.
+
+To compress an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+To compress an RFC 1952 data stream (i.e. gzip), set C<WindowBits> to
+C<WANT_GZIP>.
+
+For a definition of the meaning and valid values for C<WindowBits>
+refer to the I<zlib> documentation for I<deflateInit2>.
+
+Defaults to C<MAX_WBITS>.
+
+=item B<-MemLevel>
+
+For a definition of the meaning and valid values for C<MemLevel>
+refer to the I<zlib> documentation for I<deflateInit2>.
+
+Defaults to MAX_MEM_LEVEL.
+
+=item B<-Strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED>, C<Z_RLE>, C<Z_FIXED> and
+C<Z_HUFFMAN_ONLY>.
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item B<-Dictionary>
+
+When a dictionary is specified I<Compress::Raw::Zlib> will automatically
+call C<deflateSetDictionary> directly after calling C<deflateInit>. The
+Adler32 value for the dictionary can be obtained by calling the method
+C<$d-E<gt>dict_adler()>.
+
+The default is no dictionary.
+
+=item B<-Bufsize>
+
+Sets the initial size for the output buffer used by the C<$d-E<gt>deflate>
+and C<$d-E<gt>flush> methods. If the buffer has to be
+reallocated to increase the size, it will grow in increments of
+C<Bufsize>.
+
+The default buffer size is 4096.
+
+=item B<-AppendOutput>
+
+This option controls how data is written to the output buffer by the
+C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods.
+
+If the C<AppendOutput> option is set to false, the output buffers in the
+C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods will be truncated before
+uncompressed data is written to them.
+
+If the option is set to true, uncompressed data will be appended to the
+output buffer in the C<$d-E<gt>deflate> and C<$d-E<gt>flush> methods.
+
+This option defaults to false.
+
+=item B<-CRC32>
+
+If set to true, a crc32 checksum of the uncompressed data will be
+calculated. Use the C<$d-E<gt>crc32> method to retrieve this value.
+
+This option defaults to false.
+
+=item B<-ADLER32>
+
+If set to true, an adler32 checksum of the uncompressed data will be
+calculated. Use the C<$d-E<gt>adler32> method to retrieve this value.
+
+This option defaults to false.
+
+=back
+
+Here is an example of using the C<Compress::Raw::Zlib::Deflate> optional
+parameter list to override the default buffer size and compression
+level. All other options will take their default values.
+
+ my $d = new Compress::Raw::Zlib::Deflate ( -Bufsize => 300,
+ -Level => Z_BEST_SPEED ) ;
+
+=head2 B<$status = $d-E<gt>deflate($input, $output)>
+
+Deflates the contents of C<$input> and writes the compressed data to
+C<$output>.
+
+The C<$input> and C<$output> parameters can be either scalars or scalar
+references.
+
+When finished, C<$input> will be completely processed (assuming there
+were no errors). If the deflation was successful it writes the deflated
+data to C<$output> and returns a status value of C<Z_OK>.
+
+On error, it returns a I<zlib> error code.
+
+If the C<AppendOutput> option is set to true in the constructor for
+the C<$d> object, the compressed data will be appended to C<$output>. If
+it is false, C<$output> will be truncated before any compressed data is
+written to it.
+
+B<Note>: This method will not necessarily write compressed data to
+C<$output> every time it is called. So do not assume that there has been
+an error if the contents of C<$output> is empty on returning from
+this method. As long as the return code from the method is C<Z_OK>,
+the deflate has succeeded.
+
+=head2 B<$status = $d-E<gt>flush($output [, $flush_type]) >
+
+Typically used to finish the deflation. Any pending output will be
+written to C<$output>.
+
+Returns C<Z_OK> if successful.
+
+Note that flushing can seriously degrade the compression ratio, so it
+should only be used to terminate a decompression (using C<Z_FINISH>) or
+when you want to create a I<full flush point> (using C<Z_FULL_FLUSH>).
+
+By default the C<flush_type> used is C<Z_FINISH>. Other valid values
+for C<flush_type> are C<Z_NO_FLUSH>, C<Z_PARTIAL_FLUSH>, C<Z_SYNC_FLUSH>
+and C<Z_FULL_FLUSH>. It is strongly recommended that you only set the
+C<flush_type> parameter if you fully understand the implications of
+what it does. See the C<zlib> documentation for details.
+
+If the C<AppendOutput> option is set to true in the constructor for
+the C<$d> object, the compressed data will be appended to C<$output>. If
+it is false, C<$output> will be truncated before any compressed data is
+written to it.
+
+=head2 B<$status = $d-E<gt>deflateReset() >
+
+This method will reset the deflation object C<$d>. It can be used when you
+are compressing multiple data streams and want to use the same object to
+compress each of them. It should only be used once the previous data stream
+has been flushed successfully, i.e. a call to C<< $d->flush(Z_FINISH) >> has
+returned C<Z_OK>.
+
+Returns C<Z_OK> if successful.
+
+=head2 B<$status = $d-E<gt>deflateParams([OPT])>
+
+Change settings for the deflate object C<$d>.
+
+The list of the valid options is shown below. Options not specified
+will remain unchanged.
+
+=over 5
+
+=item B<-Level>
+
+Defines the compression level. Valid values are 0 through 9,
+C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and
+C<Z_DEFAULT_COMPRESSION>.
+
+=item B<-Strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+
+=item B<-BufSize>
+
+Sets the initial size for the output buffer used by the C<$d-E<gt>deflate>
+and C<$d-E<gt>flush> methods. If the buffer has to be
+reallocated to increase the size, it will grow in increments of
+C<Bufsize>.
+
+=back
+
+=head2 B<$status = $d-E<gt>deflateTune($good_length, $max_lazy, $nice_length, $max_chain)>
+
+Tune the internal settings for the deflate object C<$d>. This option is
+only available if you are running zlib 1.2.2.3 or better.
+
+Refer to the documentation in zlib.h for instructions on how to fly
+C<deflateTune>.
+
+=head2 B<$d-E<gt>dict_adler()>
+
+Returns the adler32 value for the dictionary.
+
+=head2 B<$d-E<gt>crc32()>
+
+Returns the crc32 value for the uncompressed data to date.
+
+If the C<CRC32> option is not enabled in the constructor for this object,
+this method will always return 0;
+
+=head2 B<$d-E<gt>adler32()>
+
+Returns the adler32 value for the uncompressed data to date.
+
+=head2 B<$d-E<gt>msg()>
+
+Returns the last error message generated by zlib.
+
+=head2 B<$d-E<gt>total_in()>
+
+Returns the total number of bytes uncompressed bytes input to deflate.
+
+=head2 B<$d-E<gt>total_out()>
+
+Returns the total number of compressed bytes output from deflate.
+
+=head2 B<$d-E<gt>get_Strategy()>
+
+Returns the deflation strategy currently used. Valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+
+=head2 B<$d-E<gt>get_Level()>
+
+Returns the compression level being used.
+
+=head2 B<$d-E<gt>get_BufSize()>
+
+Returns the buffer size used to carry out the compression.
+
+=head2 Example
+
+Here is a trivial example of using C<deflate>. It simply reads standard
+input, deflates it and writes it to standard output.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Raw::Zlib ;
+
+ binmode STDIN;
+ binmode STDOUT;
+ my $x = new Compress::Raw::Zlib::Deflate
+ or die "Cannot create a deflation stream\n" ;
+
+ my ($output, $status) ;
+ while (<>)
+ {
+ $status = $x->deflate($_, $output) ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+ }
+
+ $status = $x->flush($output) ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+
+=head1 Compress::Raw::Zlib::Inflate
+
+This section defines an interface that allows in-memory uncompression using
+the I<inflate> interface provided by zlib.
+
+Here is a definition of the interface:
+
+=head2 B< ($i, $status) = new Compress::Raw::Zlib::Inflate( [OPT] ) >
+
+Initialises an inflation object.
+
+In a list context it returns the inflation object, C<$i>, and the
+I<zlib> status code (C<$status>). In a scalar context it returns the
+inflation object only.
+
+If successful, C<$i> will hold the inflation object and C<$status> will
+be C<Z_OK>.
+
+If not successful, C<$i> will be I<undef> and C<$status> will hold the
+I<zlib> error code.
+
+The function optionally takes a number of named options specified as
+C<< -Name => value >> pairs. This allows individual options to be
+tailored without having to specify them all in the parameter list.
+
+For backward compatibility, it is also possible to pass the parameters
+as a reference to a hash containing the C<< name=>value >> pairs.
+
+Here is a list of the valid options:
+
+=over 5
+
+=item B<-WindowBits>
+
+To uncompress an RFC 1950 data stream, set C<WindowBits> to a positive
+number between 8 and 15.
+
+To uncompress an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+To uncompress an RFC 1952 data stream (i.e. gzip), set C<WindowBits> to
+C<WANT_GZIP>.
+
+To auto-detect and uncompress an RFC 1950 or RFC 1952 data stream (i.e.
+gzip), set C<WindowBits> to C<WANT_GZIP_OR_ZLIB>.
+
+For a full definition of the meaning and valid values for C<WindowBits>
+refer to the I<zlib> documentation for I<inflateInit2>.
+
+Defaults to C<MAX_WBITS>.
+
+=item B<-Bufsize>
+
+Sets the initial size for the output buffer used by the C<$i-E<gt>inflate>
+method. If the output buffer in this method has to be reallocated to
+increase the size, it will grow in increments of C<Bufsize>.
+
+Default is 4096.
+
+=item B<-Dictionary>
+
+The default is no dictionary.
+
+=item B<-AppendOutput>
+
+This option controls how data is written to the output buffer by the
+C<$i-E<gt>inflate> method.
+
+If the option is set to false, the output buffer in the C<$i-E<gt>inflate>
+method will be truncated before uncompressed data is written to it.
+
+If the option is set to true, uncompressed data will be appended to the
+output buffer by the C<$i-E<gt>inflate> method.
+
+This option defaults to false.
+
+=item B<-CRC32>
+
+If set to true, a crc32 checksum of the uncompressed data will be
+calculated. Use the C<$i-E<gt>crc32> method to retrieve this value.
+
+This option defaults to false.
+
+=item B<-ADLER32>
+
+If set to true, an adler32 checksum of the uncompressed data will be
+calculated. Use the C<$i-E<gt>adler32> method to retrieve this value.
+
+This option defaults to false.
+
+=item B<-ConsumeInput>
+
+If set to true, this option will remove compressed data from the input
+buffer of the C<< $i->inflate >> method as the inflate progresses.
+
+This option can be useful when you are processing compressed data that is
+embedded in another file/buffer. In this case the data that immediately
+follows the compressed stream will be left in the input buffer.
+
+This option defaults to true.
+
+=item B<-LimitOutput>
+
+The C<LimitOutput> option changes the behavior of the C<< $i->inflate >>
+method so that the amount of memory used by the output buffer can be
+limited.
+
+When C<LimitOutput> is used the size of the output buffer used will either
+be the value of the C<Bufsize> option or the amount of memory already
+allocated to C<$output>, whichever is larger. Predicting the output size
+available is tricky, so don't rely on getting an exact output buffer size.
+
+When C<LimitOutout> is not specified C<< $i->inflate >> will use as much
+memory as it takes to write all the uncompressed data it creates by
+uncompressing the input buffer.
+
+If C<LimitOutput> is enabled, the C<ConsumeInput> option will also be
+enabled.
+
+This option defaults to false.
+
+See L</The LimitOutput option> for a discussion on why C<LimitOutput> is
+needed and how to use it.
+
+=back
+
+Here is an example of using an optional parameter to override the default
+buffer size.
+
+ my ($i, $status) = new Compress::Raw::Zlib::Inflate( -Bufsize => 300 ) ;
+
+=head2 B< $status = $i-E<gt>inflate($input, $output [,$eof]) >
+
+Inflates the complete contents of C<$input> and writes the uncompressed
+data to C<$output>. The C<$input> and C<$output> parameters can either be
+scalars or scalar references.
+
+Returns C<Z_OK> if successful and C<Z_STREAM_END> if the end of the
+compressed data has been successfully reached.
+
+If not successful C<$status> will hold the I<zlib> error code.
+
+If the C<ConsumeInput> option has been set to true when the
+C<Compress::Raw::Zlib::Inflate> object is created, the C<$input> parameter
+is modified by C<inflate>. On completion it will contain what remains
+of the input buffer after inflation. In practice, this means that when
+the return status is C<Z_OK> the C<$input> parameter will contain an
+empty string, and when the return status is C<Z_STREAM_END> the C<$input>
+parameter will contains what (if anything) was stored in the input buffer
+after the deflated data stream.
+
+This feature is useful when processing a file format that encapsulates
+a compressed data stream (e.g. gzip, zip) and there is useful data
+immediately after the deflation stream.
+
+If the C<AppendOutput> option is set to true in the constructor for
+this object, the uncompressed data will be appended to C<$output>. If
+it is false, C<$output> will be truncated before any uncompressed data
+is written to it.
+
+The C<$eof> parameter needs a bit of explanation.
+
+Prior to version 1.2.0, zlib assumed that there was at least one trailing
+byte immediately after the compressed data stream when it was carrying out
+decompression. This normally isn't a problem because the majority of zlib
+applications guarantee that there will be data directly after the
+compressed data stream. For example, both gzip (RFC 1950) and zip both
+define trailing data that follows the compressed data stream.
+
+The C<$eof> parameter only needs to be used if B<all> of the following
+conditions apply
+
+=over 5
+
+=item 1
+
+You are either using a copy of zlib that is older than version 1.2.0 or you
+want your application code to be able to run with as many different
+versions of zlib as possible.
+
+=item 2
+
+You have set the C<WindowBits> parameter to C<-MAX_WBITS> in the constructor
+for this object, i.e. you are uncompressing a raw deflated data stream
+(RFC 1951).
+
+=item 3
+
+There is no data immediately after the compressed data stream.
+
+=back
+
+If B<all> of these are the case, then you need to set the C<$eof> parameter
+to true on the final call (and only the final call) to C<$i-E<gt>inflate>.
+
+If you have built this module with zlib >= 1.2.0, the C<$eof> parameter is
+ignored. You can still set it if you want, but it won't be used behind the
+scenes.
+
+=head2 B<$status = $i-E<gt>inflateSync($input)>
+
+This method can be used to attempt to recover good data from a compressed
+data stream that is partially corrupt.
+It scans C<$input> until it reaches either a I<full flush point> or the
+end of the buffer.
+
+If a I<full flush point> is found, C<Z_OK> is returned and C<$input>
+will be have all data up to the flush point removed. This data can then be
+passed to the C<$i-E<gt>inflate> method to be uncompressed.
+
+Any other return code means that a flush point was not found. If more
+data is available, C<inflateSync> can be called repeatedly with more
+compressed data until the flush point is found.
+
+Note I<full flush points> are not present by default in compressed
+data streams. They must have been added explicitly when the data stream
+was created by calling C<Compress::Deflate::flush> with C<Z_FULL_FLUSH>.
+
+=head2 B<$i-E<gt>dict_adler()>
+
+Returns the adler32 value for the dictionary.
+
+=head2 B<$i-E<gt>crc32()>
+
+Returns the crc32 value for the uncompressed data to date.
+
+If the C<CRC32> option is not enabled in the constructor for this object,
+this method will always return 0;
+
+=head2 B<$i-E<gt>adler32()>
+
+Returns the adler32 value for the uncompressed data to date.
+
+If the C<ADLER32> option is not enabled in the constructor for this object,
+this method will always return 0;
+
+=head2 B<$i-E<gt>msg()>
+
+Returns the last error message generated by zlib.
+
+=head2 B<$i-E<gt>total_in()>
+
+Returns the total number of bytes compressed bytes input to inflate.
+
+=head2 B<$i-E<gt>total_out()>
+
+Returns the total number of uncompressed bytes output from inflate.
+
+=head2 B<$d-E<gt>get_BufSize()>
+
+Returns the buffer size used to carry out the decompression.
+
+=head2 Examples
+
+Here is an example of using C<inflate>.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Raw::Zlib;
+
+ my $x = new Compress::Raw::Zlib::Inflate()
+ or die "Cannot create a inflation stream\n" ;
+
+ my $input = '' ;
+ binmode STDIN;
+ binmode STDOUT;
+
+ my ($output, $status) ;
+ while (read(STDIN, $input, 4096))
+ {
+ $status = $x->inflate($input, $output) ;
+
+ print $output ;
+
+ last if $status != Z_OK ;
+ }
+
+ die "inflation failed\n"
+ unless $status == Z_STREAM_END ;
+
+The next example show how to use the C<LimitOutput> option. Notice the use
+of two nested loops in this case. The outer loop reads the data from the
+input source - STDIN and the inner loop repeatedly calls C<inflate> until
+C<$input> is exhausted, we get an error, or the end of the stream is
+reached. One point worth remembering is by using the C<LimitOutput> option
+you also get C<ConsumeInput> set as well - this makes the code below much
+simpler.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Raw::Zlib;
+
+ my $x = new Compress::Raw::Zlib::Inflate(LimitOutput => 1)
+ or die "Cannot create a inflation stream\n" ;
+
+ my $input = '' ;
+ binmode STDIN;
+ binmode STDOUT;
+
+ my ($output, $status) ;
+
+ OUTER:
+ while (read(STDIN, $input, 4096))
+ {
+ do
+ {
+ $status = $x->inflate($input, $output) ;
+
+ print $output ;
+
+ last OUTER
+ unless $status == Z_OK || $status == Z_BUF_ERROR ;
+ }
+ while ($status == Z_OK && length $input);
+ }
+
+ die "inflation failed\n"
+ unless $status == Z_STREAM_END ;
+
+=head1 CHECKSUM FUNCTIONS
+
+Two functions are provided by I<zlib> to calculate checksums. For the
+Perl interface, the order of the two parameters in both functions has
+been reversed. This allows both running checksums and one off
+calculations to be done.
+
+ $crc = adler32($buffer [,$crc]) ;
+ $crc = crc32($buffer [,$crc]) ;
+
+The buffer parameters can either be a scalar or a scalar reference.
+
+If the $crc parameters is C<undef>, the crc value will be reset.
+
+If you have built this module with zlib 1.2.3 or better, two more
+CRC-related functions are available.
+
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
+
+These functions allow checksums to be merged.
+
+=head1 Misc
+
+=head2 my $version = Compress::Raw::Zlib::zlib_version();
+
+Returns the version of the zlib library.
+
+=head1 The LimitOutput option.
+
+By default C<< $i->inflate($input, $output) >> will uncompress I<all> data
+in C<$input> and write I<all> of the uncompressed data it has generated to
+C<$output>. This makes the interface to C<inflate> much simpler - if the
+method has uncompressed C<$input> successfully I<all> compressed data in
+C<$input> will have been dealt with. So if you are reading from an input
+source and uncompressing as you go the code will look something like this
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Raw::Zlib;
+
+ my $x = new Compress::Raw::Zlib::Inflate()
+ or die "Cannot create a inflation stream\n" ;
+
+ my $input = '' ;
+
+ my ($output, $status) ;
+ while (read(STDIN, $input, 4096))
+ {
+ $status = $x->inflate($input, $output) ;
+
+ print $output ;
+
+ last if $status != Z_OK ;
+ }
+
+ die "inflation failed\n"
+ unless $status == Z_STREAM_END ;
+
+The points to note are
+
+=over 5
+
+=item *
+
+The main processing loop in the code handles reading of compressed data
+from STDIN.
+
+=item *
+
+The status code returned from C<inflate> will only trigger termination of
+the main processing loop if it isn't C<Z_OK>. When C<LimitOutput> has not
+been used the C<Z_OK> status means means that the end of the compressed
+data stream has been reached or there has been an error in uncompression.
+
+=item *
+
+After the call to C<inflate> I<all> of the uncompressed data in C<$input>
+will have been processed. This means the subsequent call to C<read> can
+overwrite it's contents without any problem.
+
+=back
+
+For most use-cases the behavior described above is acceptable (this module
+and it's predecessor, C<Compress::Zlib>, have used it for over 10 years
+without an issue), but in a few very specific use-cases the amount of
+memory required for C<$output> can prohibitively large. For example, if the
+compressed data stream contains the same pattern repeated thousands of
+times, a relatively small compressed data stream can uncompress into
+hundreds of megabytes. Remember C<inflate> will keep allocating memory
+until I<all> the uncompressed data has been written to the output buffer -
+the size of C<$output> is unbounded.
+
+The C<LimitOutput> option is designed to help with this use-case.
+
+The main difference in your code when using C<LimitOutput> is having to
+deal with cases where the C<$input> parameter still contains some
+uncompressed data that C<inflate> hasn't processed yet. The status code
+returned from C<inflate> will be C<Z_OK> if uncompression took place and
+C<Z_BUF_ERROR> if the output buffer is full.
+
+Below is typical code that shows how to use C<LimitOutput>.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Raw::Zlib;
+
+ my $x = new Compress::Raw::Zlib::Inflate(LimitOutput => 1)
+ or die "Cannot create a inflation stream\n" ;
+
+ my $input = '' ;
+ binmode STDIN;
+ binmode STDOUT;
+
+ my ($output, $status) ;
+
+ OUTER:
+ while (read(STDIN, $input, 4096))
+ {
+ do
+ {
+ $status = $x->inflate($input, $output) ;
+
+ print $output ;
+
+ last OUTER
+ unless $status == Z_OK || $status == Z_BUF_ERROR ;
+ }
+ while ($status == Z_OK && length $input);
+ }
+
+ die "inflation failed\n"
+ unless $status == Z_STREAM_END ;
+
+Points to note this time:
+
+=over 5
+
+=item *
+
+There are now two nested loops in the code: the outer loop for reading the
+compressed data from STDIN, as before; and the inner loop to carry out the
+uncompression.
+
+=item *
+
+There are two exit points from the inner uncompression loop.
+
+Firstly when C<inflate> has returned a status other than C<Z_OK> or
+C<Z_BUF_ERROR>. This means that either the end of the compressed data
+stream has been reached (C<Z_STREAM_END>) or there is an error in the
+compressed data. In either of these cases there is no point in continuing
+with reading the compressed data, so both loops are terminated.
+
+The second exit point tests if there is any data left in the input buffer,
+C<$input> - remember that the C<ConsumeInput> option is automatically
+enabled when C<LimitOutput> is used. When the input buffer has been
+exhausted, the outer loop can run again and overwrite a now empty
+C<$input>.
+
+=back
+
+=head1 ACCESSING ZIP FILES
+
+Although it is possible (with some effort on your part) to use this module
+to access .zip files, there are other perl modules available that will
+do all the hard work for you. Check out C<Archive::Zip>,
+C<IO::Compress::Zip> and C<IO::Uncompress::Unzip>.
+
+=head1 CONSTANTS
+
+All the I<zlib> constants are automatically imported when you make use
+of I<Compress::Raw::Zlib>.
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/Compress/Zlib.pm b/Master/tlpkg/tlperl/lib/Compress/Zlib.pm
new file mode 100644
index 00000000000..9424df63b8b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Compress/Zlib.pm
@@ -0,0 +1,1494 @@
+
+package Compress::Zlib;
+
+require 5.004 ;
+require Exporter;
+use AutoLoader;
+use Carp ;
+use IO::Handle ;
+use Scalar::Util qw(dualvar);
+
+use IO::Compress::Base::Common 2.024 ;
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Gzip 2.024 ;
+use IO::Uncompress::Gunzip 2.024 ;
+
+use strict ;
+use warnings ;
+use bytes ;
+our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
+
+$VERSION = '2.024';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+@ISA = qw(Exporter);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ deflateInit inflateInit
+
+ compress uncompress
+
+ gzopen $gzerrno
+ );
+
+push @EXPORT, @Compress::Raw::Zlib::EXPORT ;
+
+@EXPORT_OK = qw(memGunzip memGzip zlib_version);
+%EXPORT_TAGS = (
+ ALL => \@EXPORT
+);
+
+BEGIN
+{
+ *zlib_version = \&Compress::Raw::Zlib::zlib_version;
+}
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = Compress::Raw::Zlib::constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+use constant FLAG_APPEND => 1 ;
+use constant FLAG_CRC => 2 ;
+use constant FLAG_ADLER => 4 ;
+use constant FLAG_CONSUME_INPUT => 8 ;
+
+our (@my_z_errmsg);
+
+@my_z_errmsg = (
+ "need dictionary", # Z_NEED_DICT 2
+ "stream end", # Z_STREAM_END 1
+ "", # Z_OK 0
+ "file error", # Z_ERRNO (-1)
+ "stream error", # Z_STREAM_ERROR (-2)
+ "data error", # Z_DATA_ERROR (-3)
+ "insufficient memory", # Z_MEM_ERROR (-4)
+ "buffer error", # Z_BUF_ERROR (-5)
+ "incompatible version",# Z_VERSION_ERROR(-6)
+ );
+
+
+sub _set_gzerr
+{
+ my $value = shift ;
+
+ if ($value == 0) {
+ $Compress::Zlib::gzerrno = 0 ;
+ }
+ elsif ($value == Z_ERRNO() || $value > 2) {
+ $Compress::Zlib::gzerrno = $! ;
+ }
+ else {
+ $Compress::Zlib::gzerrno = dualvar($value+0, $my_z_errmsg[2 - $value]);
+ }
+
+ return $value ;
+}
+
+sub _set_gzerr_undef
+{
+ _set_gzerr(@_);
+ return undef;
+}
+sub _save_gzerr
+{
+ my $gz = shift ;
+ my $test_eof = shift ;
+
+ my $value = $gz->errorNo() || 0 ;
+
+ if ($test_eof) {
+ #my $gz = $self->[0] ;
+ # gzread uses Z_STREAM_END to denote a successful end
+ $value = Z_STREAM_END() if $gz->eof() && $value == 0 ;
+ }
+
+ _set_gzerr($value) ;
+}
+
+sub gzopen($$)
+{
+ my ($file, $mode) = @_ ;
+
+ my $gz ;
+ my %defOpts = (Level => Z_DEFAULT_COMPRESSION(),
+ Strategy => Z_DEFAULT_STRATEGY(),
+ );
+
+ my $writing ;
+ $writing = ! ($mode =~ /r/i) ;
+ $writing = ($mode =~ /[wa]/i) ;
+
+ $defOpts{Level} = $1 if $mode =~ /(\d)/;
+ $defOpts{Strategy} = Z_FILTERED() if $mode =~ /f/i;
+ $defOpts{Strategy} = Z_HUFFMAN_ONLY() if $mode =~ /h/i;
+ $defOpts{Append} = 1 if $mode =~ /a/i;
+
+ my $infDef = $writing ? 'deflate' : 'inflate';
+ my @params = () ;
+
+ croak "gzopen: file parameter is not a filehandle or filename"
+ unless isaFilehandle $file || isaFilename $file ||
+ (ref $file && ref $file eq 'SCALAR');
+
+ return undef unless $mode =~ /[rwa]/i ;
+
+ _set_gzerr(0) ;
+
+ if ($writing) {
+ $gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1,
+ %defOpts)
+ or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError;
+ }
+ else {
+ $gz = new IO::Uncompress::Gunzip($file,
+ Transparent => 1,
+ Append => 0,
+ AutoClose => 1,
+ MultiStream => 1,
+ Strict => 0)
+ or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError;
+ }
+
+ return undef
+ if ! defined $gz ;
+
+ bless [$gz, $infDef], 'Compress::Zlib::gzFile';
+}
+
+sub Compress::Zlib::gzFile::gzread
+{
+ my $self = shift ;
+
+ return _set_gzerr(Z_STREAM_ERROR())
+ if $self->[1] ne 'inflate';
+
+ my $len = defined $_[1] ? $_[1] : 4096 ;
+
+ if ($self->gzeof() || $len == 0) {
+ # Zap the output buffer to match ver 1 behaviour.
+ $_[0] = "" ;
+ return 0 ;
+ }
+
+ my $gz = $self->[0] ;
+ my $status = $gz->read($_[0], $len) ;
+ _save_gzerr($gz, 1);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gzreadline
+{
+ my $self = shift ;
+
+ my $gz = $self->[0] ;
+ {
+ # Maintain backward compatibility with 1.x behaviour
+ # It didn't support $/, so this can't either.
+ local $/ = "\n" ;
+ $_[0] = $gz->getline() ;
+ }
+ _save_gzerr($gz, 1);
+ return defined $_[0] ? length $_[0] : 0 ;
+}
+
+sub Compress::Zlib::gzFile::gzwrite
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
+
+ return _set_gzerr(Z_STREAM_ERROR())
+ if $self->[1] ne 'deflate';
+
+ $] >= 5.008 and (utf8::downgrade($_[0], 1)
+ or croak "Wide character in gzwrite");
+
+ my $status = $gz->write($_[0]) ;
+ _save_gzerr($gz);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gztell
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
+ my $status = $gz->tell() ;
+ _save_gzerr($gz);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gzseek
+{
+ my $self = shift ;
+ my $offset = shift ;
+ my $whence = shift ;
+
+ my $gz = $self->[0] ;
+ my $status ;
+ eval { $status = $gz->seek($offset, $whence) ; };
+ if ($@)
+ {
+ my $error = $@;
+ $error =~ s/^.*: /gzseek: /;
+ $error =~ s/ at .* line \d+\s*$//;
+ croak $error;
+ }
+ _save_gzerr($gz);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gzflush
+{
+ my $self = shift ;
+ my $f = shift ;
+
+ my $gz = $self->[0] ;
+ my $status = $gz->flush($f) ;
+ my $err = _save_gzerr($gz);
+ return $status ? 0 : $err;
+}
+
+sub Compress::Zlib::gzFile::gzclose
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
+
+ my $status = $gz->close() ;
+ my $err = _save_gzerr($gz);
+ return $status ? 0 : $err;
+}
+
+sub Compress::Zlib::gzFile::gzeof
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
+
+ return 0
+ if $self->[1] ne 'inflate';
+
+ my $status = $gz->eof() ;
+ _save_gzerr($gz);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gzsetparams
+{
+ my $self = shift ;
+ croak "Usage: Compress::Zlib::gzFile::gzsetparams(file, level, strategy)"
+ unless @_ eq 2 ;
+
+ my $gz = $self->[0] ;
+ my $level = shift ;
+ my $strategy = shift;
+
+ return _set_gzerr(Z_STREAM_ERROR())
+ if $self->[1] ne 'deflate';
+
+ my $status = *$gz->{Compress}->deflateParams(-Level => $level,
+ -Strategy => $strategy);
+ _save_gzerr($gz);
+ return $status ;
+}
+
+sub Compress::Zlib::gzFile::gzerror
+{
+ my $self = shift ;
+ my $gz = $self->[0] ;
+
+ return $Compress::Zlib::gzerrno ;
+}
+
+
+sub compress($;$)
+{
+ my ($x, $output, $err, $in) =('', '', '', '') ;
+
+ if (ref $_[0] ) {
+ $in = $_[0] ;
+ croak "not a scalar reference" unless ref $in eq 'SCALAR' ;
+ }
+ else {
+ $in = \$_[0] ;
+ }
+
+ $] >= 5.008 and (utf8::downgrade($$in, 1)
+ or croak "Wide character in compress");
+
+ my $level = (@_ == 2 ? $_[1] : Z_DEFAULT_COMPRESSION() );
+
+ $x = new Compress::Raw::Zlib::Deflate -AppendOutput => 1, -Level => $level
+ or return undef ;
+
+ $err = $x->deflate($in, $output) ;
+ return undef unless $err == Z_OK() ;
+
+ $err = $x->flush($output) ;
+ return undef unless $err == Z_OK() ;
+
+ return $output ;
+
+}
+
+sub uncompress($)
+{
+ my ($x, $output, $err, $in) =('', '', '', '') ;
+
+ if (ref $_[0] ) {
+ $in = $_[0] ;
+ croak "not a scalar reference" unless ref $in eq 'SCALAR' ;
+ }
+ else {
+ $in = \$_[0] ;
+ }
+
+ $] >= 5.008 and (utf8::downgrade($$in, 1)
+ or croak "Wide character in uncompress");
+
+ $x = new Compress::Raw::Zlib::Inflate -ConsumeInput => 0 or return undef ;
+
+ $err = $x->inflate($in, $output) ;
+ return undef unless $err == Z_STREAM_END() ;
+
+ return $output ;
+}
+
+
+
+sub deflateInit(@)
+{
+ my ($got) = ParseParameters(0,
+ {
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
+ }, @_ ) ;
+
+ croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $obj ;
+
+ my $status = 0 ;
+ ($obj, $status) =
+ Compress::Raw::Zlib::_deflateInit(0,
+ $got->value('Level'),
+ $got->value('Method'),
+ $got->value('WindowBits'),
+ $got->value('MemLevel'),
+ $got->value('Strategy'),
+ $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
+
+ my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ;
+ return wantarray ? ($x, $status) : $x ;
+}
+
+sub inflateInit(@)
+{
+ my ($got) = ParseParameters(0,
+ {
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
+ }, @_) ;
+
+
+ croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " .
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
+
+ my $status = 0 ;
+ my $obj ;
+ ($obj, $status) = Compress::Raw::Zlib::_inflateInit(FLAG_CONSUME_INPUT,
+ $got->value('WindowBits'),
+ $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
+
+ my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ;
+
+ wantarray ? ($x, $status) : $x ;
+}
+
+package Zlib::OldDeflate ;
+
+our (@ISA);
+@ISA = qw(Compress::Raw::Zlib::deflateStream);
+
+
+sub deflate
+{
+ my $self = shift ;
+ my $output ;
+
+ my $status = $self->SUPER::deflate($_[0], $output) ;
+ wantarray ? ($output, $status) : $output ;
+}
+
+sub flush
+{
+ my $self = shift ;
+ my $output ;
+ my $flag = shift || Compress::Zlib::Z_FINISH();
+ my $status = $self->SUPER::flush($output, $flag) ;
+
+ wantarray ? ($output, $status) : $output ;
+}
+
+package Zlib::OldInflate ;
+
+our (@ISA);
+@ISA = qw(Compress::Raw::Zlib::inflateStream);
+
+sub inflate
+{
+ my $self = shift ;
+ my $output ;
+ my $status = $self->SUPER::inflate($_[0], $output) ;
+ wantarray ? ($output, $status) : $output ;
+}
+
+package Compress::Zlib ;
+
+use IO::Compress::Gzip::Constants 2.024 ;
+
+sub memGzip($)
+{
+ my $out;
+
+ # if the deflation buffer isn't a reference, make it one
+ my $string = (ref $_[0] ? $_[0] : \$_[0]) ;
+
+ $] >= 5.008 and (utf8::downgrade($$string, 1)
+ or croak "Wide character in memGzip");
+
+ _set_gzerr(0);
+ if ( ! IO::Compress::Gzip::gzip($string, \$out, Minimal => 1) )
+ {
+ $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError;
+ return undef ;
+ }
+
+ return $out;
+}
+
+sub _removeGzipHeader($)
+{
+ my $string = shift ;
+
+ return Z_DATA_ERROR()
+ if length($$string) < GZIP_MIN_HEADER_SIZE ;
+
+ my ($magic1, $magic2, $method, $flags, $time, $xflags, $oscode) =
+ unpack ('CCCCVCC', $$string);
+
+ return Z_DATA_ERROR()
+ unless $magic1 == GZIP_ID1 and $magic2 == GZIP_ID2 and
+ $method == Z_DEFLATED() and !($flags & GZIP_FLG_RESERVED) ;
+ substr($$string, 0, GZIP_MIN_HEADER_SIZE) = '' ;
+
+ # skip extra field
+ if ($flags & GZIP_FLG_FEXTRA)
+ {
+ return Z_DATA_ERROR()
+ if length($$string) < GZIP_FEXTRA_HEADER_SIZE ;
+
+ my ($extra_len) = unpack ('v', $$string);
+ $extra_len += GZIP_FEXTRA_HEADER_SIZE;
+ return Z_DATA_ERROR()
+ if length($$string) < $extra_len ;
+
+ substr($$string, 0, $extra_len) = '';
+ }
+
+ # skip orig name
+ if ($flags & GZIP_FLG_FNAME)
+ {
+ my $name_end = index ($$string, GZIP_NULL_BYTE);
+ return Z_DATA_ERROR()
+ if $name_end == -1 ;
+ substr($$string, 0, $name_end + 1) = '';
+ }
+
+ # skip comment
+ if ($flags & GZIP_FLG_FCOMMENT)
+ {
+ my $comment_end = index ($$string, GZIP_NULL_BYTE);
+ return Z_DATA_ERROR()
+ if $comment_end == -1 ;
+ substr($$string, 0, $comment_end + 1) = '';
+ }
+
+ # skip header crc
+ if ($flags & GZIP_FLG_FHCRC)
+ {
+ return Z_DATA_ERROR()
+ if length ($$string) < GZIP_FHCRC_SIZE ;
+ substr($$string, 0, GZIP_FHCRC_SIZE) = '';
+ }
+
+ return Z_OK();
+}
+
+sub _ret_gun_error
+{
+ $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError;
+ return undef;
+}
+
+
+sub memGunzip($)
+{
+ # if the buffer isn't a reference, make it one
+ my $string = (ref $_[0] ? $_[0] : \$_[0]);
+
+ $] >= 5.008 and (utf8::downgrade($$string, 1)
+ or croak "Wide character in memGunzip");
+
+ _set_gzerr(0);
+
+ my $status = _removeGzipHeader($string) ;
+ $status == Z_OK()
+ or return _set_gzerr_undef($status);
+
+ my $bufsize = length $$string > 4096 ? length $$string : 4096 ;
+ my $x = new Compress::Raw::Zlib::Inflate({-WindowBits => - MAX_WBITS(),
+ -Bufsize => $bufsize})
+
+ or return _ret_gun_error();
+
+ my $output = "" ;
+ $status = $x->inflate($string, $output);
+
+ if ( $status == Z_OK() )
+ {
+ _set_gzerr(Z_DATA_ERROR());
+ return undef;
+ }
+
+ return _ret_gun_error()
+ if ($status != Z_STREAM_END());
+
+ if (length $$string >= 8)
+ {
+ my ($crc, $len) = unpack ("VV", substr($$string, 0, 8));
+ substr($$string, 0, 8) = '';
+ return _set_gzerr_undef(Z_DATA_ERROR())
+ unless $len == length($output) and
+ $crc == crc32($output);
+ }
+ else
+ {
+ $$string = '';
+ }
+
+ return $output;
+}
+
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+__END__
+
+
+=head1 NAME
+
+Compress::Zlib - Interface to zlib compression library
+
+=head1 SYNOPSIS
+
+ use Compress::Zlib ;
+
+ ($d, $status) = deflateInit( [OPT] ) ;
+ $status = $d->deflate($input, $output) ;
+ $status = $d->flush([$flush_type]) ;
+ $d->deflateParams(OPTS) ;
+ $d->deflateTune(OPTS) ;
+ $d->dict_adler() ;
+ $d->crc32() ;
+ $d->adler32() ;
+ $d->total_in() ;
+ $d->total_out() ;
+ $d->msg() ;
+ $d->get_Strategy();
+ $d->get_Level();
+ $d->get_BufSize();
+
+ ($i, $status) = inflateInit( [OPT] ) ;
+ $status = $i->inflate($input, $output [, $eof]) ;
+ $status = $i->inflateSync($input) ;
+ $i->dict_adler() ;
+ $d->crc32() ;
+ $d->adler32() ;
+ $i->total_in() ;
+ $i->total_out() ;
+ $i->msg() ;
+ $d->get_BufSize();
+
+ $dest = compress($source) ;
+ $dest = uncompress($source) ;
+
+ $gz = gzopen($filename or filehandle, $mode) ;
+ $bytesread = $gz->gzread($buffer [,$size]) ;
+ $bytesread = $gz->gzreadline($line) ;
+ $byteswritten = $gz->gzwrite($buffer) ;
+ $status = $gz->gzflush($flush) ;
+ $offset = $gz->gztell() ;
+ $status = $gz->gzseek($offset, $whence) ;
+ $status = $gz->gzclose() ;
+ $status = $gz->gzeof() ;
+ $status = $gz->gzsetparams($level, $strategy) ;
+ $errstring = $gz->gzerror() ;
+ $gzerrno
+
+ $dest = Compress::Zlib::memGzip($buffer) ;
+ $dest = Compress::Zlib::memGunzip($buffer) ;
+
+ $crc = adler32($buffer [,$crc]) ;
+ $crc = crc32($buffer [,$crc]) ;
+
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
+
+ my $version = Compress::Raw::Zlib::zlib_version();
+
+=head1 DESCRIPTION
+
+The I<Compress::Zlib> module provides a Perl interface to the I<zlib>
+compression library (see L</AUTHOR> for details about where to get
+I<zlib>).
+
+The C<Compress::Zlib> module can be split into two general areas of
+functionality, namely a simple read/write interface to I<gzip> files
+and a low-level in-memory compression/decompression interface.
+
+Each of these areas will be discussed in the following sections.
+
+=head2 Notes for users of Compress::Zlib version 1
+
+The main change in C<Compress::Zlib> version 2.x is that it does not now
+interface directly to the zlib library. Instead it uses the
+C<IO::Compress::Gzip> and C<IO::Uncompress::Gunzip> modules for
+reading/writing gzip files, and the C<Compress::Raw::Zlib> module for some
+low-level zlib access.
+
+The interface provided by version 2 of this module should be 100% backward
+compatible with version 1. If you find a difference in the expected
+behaviour please contact the author (See L</AUTHOR>). See L<GZIP INTERFACE>
+
+With the creation of the C<IO::Compress> and C<IO::Uncompress> modules no
+new features are planned for C<Compress::Zlib> - the new modules do
+everything that C<Compress::Zlib> does and then some. Development on
+C<Compress::Zlib> will be limited to bug fixes only.
+
+If you are writing new code, your first port of call should be one of the
+new C<IO::Compress> or C<IO::Uncompress> modules.
+
+=head1 GZIP INTERFACE
+
+A number of functions are supplied in I<zlib> for reading and writing
+I<gzip> files that conform to RFC 1952. This module provides an interface
+to most of them.
+
+If you have previously used C<Compress::Zlib> 1.x, the following
+enhancements/changes have been made to the C<gzopen> interface:
+
+=over 5
+
+=item 1
+
+If you want to to open either STDIN or STDOUT with C<gzopen>, you can now
+optionally use the special filename "C<->" as a synonym for C<\*STDIN> and
+C<\*STDOUT>.
+
+=item 2
+
+In C<Compress::Zlib> version 1.x, C<gzopen> used the zlib library to open
+the underlying file. This made things especially tricky when a Perl
+filehandle was passed to C<gzopen>. Behind the scenes the numeric C file
+descriptor had to be extracted from the Perl filehandle and this passed to
+the zlib library.
+
+Apart from being non-portable to some operating systems, this made it
+difficult to use C<gzopen> in situations where you wanted to extract/create
+a gzip data stream that is embedded in a larger file, without having to
+resort to opening and closing the file multiple times.
+
+It also made it impossible to pass a perl filehandle that wasn't associated
+with a real filesystem file, like, say, an C<IO::String>.
+
+In C<Compress::Zlib> version 2.x, the C<gzopen> interface has been
+completely rewritten to use the L<IO::Compress::Gzip|IO::Compress::Gzip>
+for writing gzip files and L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>
+for reading gzip files. None of the limitations mentioned above apply.
+
+=item 3
+
+Addition of C<gzseek> to provide a restricted C<seek> interface.
+
+=item 4.
+
+Added C<gztell>.
+
+=back
+
+A more complete and flexible interface for reading/writing gzip
+files/buffers is included with the module C<IO-Compress-Zlib>. See
+L<IO::Compress::Gzip|IO::Compress::Gzip> and
+L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for more details.
+
+=over 5
+
+=item B<$gz = gzopen($filename, $mode)>
+
+=item B<$gz = gzopen($filehandle, $mode)>
+
+This function opens either the I<gzip> file C<$filename> for reading or
+writing or attaches to the opened filehandle, C<$filehandle>.
+It returns an object on success and C<undef> on failure.
+
+When writing a gzip file this interface will I<always> create the smallest
+possible gzip header (exactly 10 bytes). If you want greater control over
+what gets stored in the gzip header (like the original filename or a
+comment) use L<IO::Compress::Gzip|IO::Compress::Gzip> instead. Similarly if
+you want to read the contents of the gzip header use
+L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>.
+
+The second parameter, C<$mode>, is used to specify whether the file is
+opened for reading or writing and to optionally specify a compression
+level and compression strategy when writing. The format of the C<$mode>
+parameter is similar to the mode parameter to the 'C' function C<fopen>,
+so "rb" is used to open for reading, "wb" for writing and "ab" for
+appending (writing at the end of the file).
+
+To specify a compression level when writing, append a digit between 0
+and 9 to the mode string -- 0 means no compression and 9 means maximum
+compression.
+If no compression level is specified Z_DEFAULT_COMPRESSION is used.
+
+To specify the compression strategy when writing, append 'f' for filtered
+data, 'h' for Huffman only compression, or 'R' for run-length encoding.
+If no strategy is specified Z_DEFAULT_STRATEGY is used.
+
+So, for example, "wb9" means open for writing with the maximum compression
+using the default strategy and "wb4R" means open for writing with compression
+level 4 and run-length encoding.
+
+Refer to the I<zlib> documentation for the exact format of the C<$mode>
+parameter.
+
+=item B<$bytesread = $gz-E<gt>gzread($buffer [, $size]) ;>
+
+Reads C<$size> bytes from the compressed file into C<$buffer>. If
+C<$size> is not specified, it will default to 4096. If the scalar
+C<$buffer> is not large enough, it will be extended automatically.
+
+Returns the number of bytes actually read. On EOF it returns 0 and in
+the case of an error, -1.
+
+=item B<$bytesread = $gz-E<gt>gzreadline($line) ;>
+
+Reads the next line from the compressed file into C<$line>.
+
+Returns the number of bytes actually read. On EOF it returns 0 and in
+the case of an error, -1.
+
+It is legal to intermix calls to C<gzread> and C<gzreadline>.
+
+To maintain backward compatibility with version 1.x of this module
+C<gzreadline> ignores the C<$/> variable - it I<always> uses the string
+C<"\n"> as the line delimiter.
+
+If you want to read a gzip file a line at a time and have it respect the
+C<$/> variable (or C<$INPUT_RECORD_SEPARATOR>, or C<$RS> when C<English> is
+in use) see L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>.
+
+=item B<$byteswritten = $gz-E<gt>gzwrite($buffer) ;>
+
+Writes the contents of C<$buffer> to the compressed file. Returns the
+number of bytes actually written, or 0 on error.
+
+=item B<$status = $gz-E<gt>gzflush($flush_type) ;>
+
+Flushes all pending output into the compressed file.
+
+This method takes an optional parameter, C<$flush_type>, that controls
+how the flushing will be carried out. By default the C<$flush_type>
+used is C<Z_FINISH>. Other valid values for C<$flush_type> are
+C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
+strongly recommended that you only set the C<flush_type> parameter if
+you fully understand the implications of what it does - overuse of C<flush>
+can seriously degrade the level of compression achieved. See the C<zlib>
+documentation for details.
+
+Returns 0 on success.
+
+=item B<$offset = $gz-E<gt>gztell() ;>
+
+Returns the uncompressed file offset.
+
+=item B<$status = $gz-E<gt>gzseek($offset, $whence) ;>
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the compressed file.
+It is a fatal error to attempt to seek backward.
+
+When opened for writing, empty parts of the file will have NULL (0x00)
+bytes written to them.
+
+The C<$whence> parameter should be one of SEEK_SET, SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=item B<$gz-E<gt>gzclose>
+
+Closes the compressed file. Any pending data is flushed to the file
+before it is closed.
+
+Returns 0 on success.
+
+=item B<$gz-E<gt>gzsetparams($level, $strategy>
+
+Change settings for the deflate stream C<$gz>.
+
+The list of the valid options is shown below. Options not specified
+will remain unchanged.
+
+Note: This method is only available if you are running zlib 1.0.6 or better.
+
+=over 5
+
+=item B<$level>
+
+Defines the compression level. Valid values are 0 through 9,
+C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and
+C<Z_DEFAULT_COMPRESSION>.
+
+=item B<$strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+
+=back
+
+=item B<$gz-E<gt>gzerror>
+
+Returns the I<zlib> error message or number for the last operation
+associated with C<$gz>. The return value will be the I<zlib> error
+number when used in a numeric context and the I<zlib> error message
+when used in a string context. The I<zlib> error number constants,
+shown below, are available for use.
+
+ Z_OK
+ Z_STREAM_END
+ Z_ERRNO
+ Z_STREAM_ERROR
+ Z_DATA_ERROR
+ Z_MEM_ERROR
+ Z_BUF_ERROR
+
+=item B<$gzerrno>
+
+The C<$gzerrno> scalar holds the error code associated with the most
+recent I<gzip> routine. Note that unlike C<gzerror()>, the error is
+I<not> associated with a particular file.
+
+As with C<gzerror()> it returns an error number in numeric context and
+an error message in string context. Unlike C<gzerror()> though, the
+error message will correspond to the I<zlib> message when the error is
+associated with I<zlib> itself, or the UNIX error message when it is
+not (i.e. I<zlib> returned C<Z_ERRORNO>).
+
+As there is an overlap between the error numbers used by I<zlib> and
+UNIX, C<$gzerrno> should only be used to check for the presence of
+I<an> error in numeric context. Use C<gzerror()> to check for specific
+I<zlib> errors. The I<gzcat> example below shows how the variable can
+be used safely.
+
+=back
+
+=head2 Examples
+
+Here is an example script which uses the interface. It implements a
+I<gzcat> function.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Zlib ;
+
+ # use stdin if no files supplied
+ @ARGV = '-' unless @ARGV ;
+
+ foreach my $file (@ARGV) {
+ my $buffer ;
+
+ my $gz = gzopen($file, "rb")
+ or die "Cannot open $file: $gzerrno\n" ;
+
+ print $buffer while $gz->gzread($buffer) > 0 ;
+
+ die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n"
+ if $gzerrno != Z_STREAM_END ;
+
+ $gz->gzclose() ;
+ }
+
+Below is a script which makes use of C<gzreadline>. It implements a
+very simple I<grep> like script.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Zlib ;
+
+ die "Usage: gzgrep pattern [file...]\n"
+ unless @ARGV >= 1;
+
+ my $pattern = shift ;
+
+ # use stdin if no files supplied
+ @ARGV = '-' unless @ARGV ;
+
+ foreach my $file (@ARGV) {
+ my $gz = gzopen($file, "rb")
+ or die "Cannot open $file: $gzerrno\n" ;
+
+ while ($gz->gzreadline($_) > 0) {
+ print if /$pattern/ ;
+ }
+
+ die "Error reading from $file: $gzerrno\n"
+ if $gzerrno != Z_STREAM_END ;
+
+ $gz->gzclose() ;
+ }
+
+This script, I<gzstream>, does the opposite of the I<gzcat> script
+above. It reads from standard input and writes a gzip data stream to
+standard output.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Zlib ;
+
+ binmode STDOUT; # gzopen only sets it on the fd
+
+ my $gz = gzopen(\*STDOUT, "wb")
+ or die "Cannot open stdout: $gzerrno\n" ;
+
+ while (<>) {
+ $gz->gzwrite($_)
+ or die "error writing: $gzerrno\n" ;
+ }
+
+ $gz->gzclose ;
+
+=head2 Compress::Zlib::memGzip
+
+This function is used to create an in-memory gzip file with the minimum
+possible gzip header (exactly 10 bytes).
+
+ $dest = Compress::Zlib::memGzip($buffer)
+ or die "Cannot compress: $gzerrno\n";
+
+If successful, it returns the in-memory gzip file. Otherwise it returns
+C<undef> and the C<$gzerrno> variable will store the zlib error code.
+
+The C<$buffer> parameter can either be a scalar or a scalar reference.
+
+See L<IO::Compress::Gzip|IO::Compress::Gzip> for an alternative way to
+carry out in-memory gzip compression.
+
+=head2 Compress::Zlib::memGunzip
+
+This function is used to uncompress an in-memory gzip file.
+
+ $dest = Compress::Zlib::memGunzip($buffer)
+ or die "Cannot uncomprss: $gzerrno\n";
+
+If successful, it returns the uncompressed gzip file. Otherwise it
+returns C<undef> and the C<$gzerrno> variable will store the zlib error
+code.
+
+The C<$buffer> parameter can either be a scalar or a scalar reference. The
+contents of the C<$buffer> parameter are destroyed after calling this function.
+
+If C<$buffer> consists of multiple concatenated gzip data streams only the
+first will be uncompressed. Use C<gunzip> with the C<MultiStream> option in
+the C<IO::Uncompress::Gunzip> module if you need to deal with concatenated
+data streams.
+
+See L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip> for an alternative way
+to carry out in-memory gzip uncompression.
+
+=head1 COMPRESS/UNCOMPRESS
+
+Two functions are provided to perform in-memory compression/uncompression of
+RFC 1950 data streams. They are called C<compress> and C<uncompress>.
+
+=over 5
+
+=item B<$dest = compress($source [, $level] ) ;>
+
+Compresses C<$source>. If successful it returns the compressed
+data. Otherwise it returns I<undef>.
+
+The source buffer, C<$source>, can either be a scalar or a scalar
+reference.
+
+The C<$level> parameter defines the compression level. Valid values are
+0 through 9, C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>,
+C<Z_BEST_COMPRESSION>, and C<Z_DEFAULT_COMPRESSION>.
+If C<$level> is not specified C<Z_DEFAULT_COMPRESSION> will be used.
+
+=item B<$dest = uncompress($source) ;>
+
+Uncompresses C<$source>. If successful it returns the uncompressed
+data. Otherwise it returns I<undef>.
+
+The source buffer can either be a scalar or a scalar reference.
+
+=back
+
+Please note: the two functions defined above are I<not> compatible with
+the Unix commands of the same name.
+
+See L<IO::Deflate|IO::Deflate> and L<IO::Inflate|IO::Inflate> included with
+this distribution for an alternative interface for reading/writing RFC 1950
+files/buffers.
+
+=head1 Deflate Interface
+
+This section defines an interface that allows in-memory compression using
+the I<deflate> interface provided by zlib.
+
+Here is a definition of the interface available:
+
+=head2 B<($d, $status) = deflateInit( [OPT] )>
+
+Initialises a deflation stream.
+
+It combines the features of the I<zlib> functions C<deflateInit>,
+C<deflateInit2> and C<deflateSetDictionary>.
+
+If successful, it will return the initialised deflation stream, C<$d>
+and C<$status> of C<Z_OK> in a list context. In scalar context it
+returns the deflation stream, C<$d>, only.
+
+If not successful, the returned deflation stream (C<$d>) will be
+I<undef> and C<$status> will hold the exact I<zlib> error code.
+
+The function optionally takes a number of named options specified as
+C<< -Name=>value >> pairs. This allows individual options to be
+tailored without having to specify them all in the parameter list.
+
+For backward compatibility, it is also possible to pass the parameters
+as a reference to a hash containing the name=>value pairs.
+
+The function takes one optional parameter, a reference to a hash. The
+contents of the hash allow the deflation interface to be tailored.
+
+Here is a list of the valid options:
+
+=over 5
+
+=item B<-Level>
+
+Defines the compression level. Valid values are 0 through 9,
+C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and
+C<Z_DEFAULT_COMPRESSION>.
+
+The default is Z_DEFAULT_COMPRESSION.
+
+=item B<-Method>
+
+Defines the compression method. The only valid value at present (and
+the default) is Z_DEFLATED.
+
+=item B<-WindowBits>
+
+To create an RFC 1950 data stream, set C<WindowBits> to a positive number.
+
+To create an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+For a full definition of the meaning and valid values for C<WindowBits> refer
+to the I<zlib> documentation for I<deflateInit2>.
+
+Defaults to MAX_WBITS.
+
+=item B<-MemLevel>
+
+For a definition of the meaning and valid values for C<MemLevel>
+refer to the I<zlib> documentation for I<deflateInit2>.
+
+Defaults to MAX_MEM_LEVEL.
+
+=item B<-Strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item B<-Dictionary>
+
+When a dictionary is specified I<Compress::Zlib> will automatically
+call C<deflateSetDictionary> directly after calling C<deflateInit>. The
+Adler32 value for the dictionary can be obtained by calling the method
+C<$d->dict_adler()>.
+
+The default is no dictionary.
+
+=item B<-Bufsize>
+
+Sets the initial size for the deflation buffer. If the buffer has to be
+reallocated to increase the size, it will grow in increments of
+C<Bufsize>.
+
+The default is 4096.
+
+=back
+
+Here is an example of using the C<deflateInit> optional parameter list
+to override the default buffer size and compression level. All other
+options will take their default values.
+
+ deflateInit( -Bufsize => 300,
+ -Level => Z_BEST_SPEED ) ;
+
+=head2 B<($out, $status) = $d-E<gt>deflate($buffer)>
+
+Deflates the contents of C<$buffer>. The buffer can either be a scalar
+or a scalar reference. When finished, C<$buffer> will be
+completely processed (assuming there were no errors). If the deflation
+was successful it returns the deflated output, C<$out>, and a status
+value, C<$status>, of C<Z_OK>.
+
+On error, C<$out> will be I<undef> and C<$status> will contain the
+I<zlib> error code.
+
+In a scalar context C<deflate> will return C<$out> only.
+
+As with the I<deflate> function in I<zlib>, it is not necessarily the
+case that any output will be produced by this method. So don't rely on
+the fact that C<$out> is empty for an error test.
+
+=head2 B<($out, $status) = $d-E<gt>flush()>
+=head2 B<($out, $status) = $d-E<gt>flush($flush_type)>
+
+Typically used to finish the deflation. Any pending output will be
+returned via C<$out>.
+C<$status> will have a value C<Z_OK> if successful.
+
+In a scalar context C<flush> will return C<$out> only.
+
+Note that flushing can seriously degrade the compression ratio, so it
+should only be used to terminate a decompression (using C<Z_FINISH>) or
+when you want to create a I<full flush point> (using C<Z_FULL_FLUSH>).
+
+By default the C<flush_type> used is C<Z_FINISH>. Other valid values
+for C<flush_type> are C<Z_NO_FLUSH>, C<Z_PARTIAL_FLUSH>, C<Z_SYNC_FLUSH>
+and C<Z_FULL_FLUSH>. It is strongly recommended that you only set the
+C<flush_type> parameter if you fully understand the implications of
+what it does. See the C<zlib> documentation for details.
+
+=head2 B<$status = $d-E<gt>deflateParams([OPT])>
+
+Change settings for the deflate stream C<$d>.
+
+The list of the valid options is shown below. Options not specified
+will remain unchanged.
+
+=over 5
+
+=item B<-Level>
+
+Defines the compression level. Valid values are 0 through 9,
+C<Z_NO_COMPRESSION>, C<Z_BEST_SPEED>, C<Z_BEST_COMPRESSION>, and
+C<Z_DEFAULT_COMPRESSION>.
+
+=item B<-Strategy>
+
+Defines the strategy used to tune the compression. The valid values are
+C<Z_DEFAULT_STRATEGY>, C<Z_FILTERED> and C<Z_HUFFMAN_ONLY>.
+
+=back
+
+=head2 B<$d-E<gt>dict_adler()>
+
+Returns the adler32 value for the dictionary.
+
+=head2 B<$d-E<gt>msg()>
+
+Returns the last error message generated by zlib.
+
+=head2 B<$d-E<gt>total_in()>
+
+Returns the total number of bytes uncompressed bytes input to deflate.
+
+=head2 B<$d-E<gt>total_out()>
+
+Returns the total number of compressed bytes output from deflate.
+
+=head2 Example
+
+Here is a trivial example of using C<deflate>. It simply reads standard
+input, deflates it and writes it to standard output.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Zlib ;
+
+ binmode STDIN;
+ binmode STDOUT;
+ my $x = deflateInit()
+ or die "Cannot create a deflation stream\n" ;
+
+ my ($output, $status) ;
+ while (<>)
+ {
+ ($output, $status) = $x->deflate($_) ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+ }
+
+ ($output, $status) = $x->flush() ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+
+=head1 Inflate Interface
+
+This section defines the interface available that allows in-memory
+uncompression using the I<deflate> interface provided by zlib.
+
+Here is a definition of the interface:
+
+=head2 B<($i, $status) = inflateInit()>
+
+Initialises an inflation stream.
+
+In a list context it returns the inflation stream, C<$i>, and the
+I<zlib> status code in C<$status>. In a scalar context it returns the
+inflation stream only.
+
+If successful, C<$i> will hold the inflation stream and C<$status> will
+be C<Z_OK>.
+
+If not successful, C<$i> will be I<undef> and C<$status> will hold the
+I<zlib> error code.
+
+The function optionally takes a number of named options specified as
+C<< -Name=>value >> pairs. This allows individual options to be
+tailored without having to specify them all in the parameter list.
+
+For backward compatibility, it is also possible to pass the parameters
+as a reference to a hash containing the name=>value pairs.
+
+The function takes one optional parameter, a reference to a hash. The
+contents of the hash allow the deflation interface to be tailored.
+
+Here is a list of the valid options:
+
+=over 5
+
+=item B<-WindowBits>
+
+To uncompress an RFC 1950 data stream, set C<WindowBits> to a positive number.
+
+To uncompress an RFC 1951 data stream, set C<WindowBits> to C<-MAX_WBITS>.
+
+For a full definition of the meaning and valid values for C<WindowBits> refer
+to the I<zlib> documentation for I<inflateInit2>.
+
+Defaults to MAX_WBITS.
+
+=item B<-Bufsize>
+
+Sets the initial size for the inflation buffer. If the buffer has to be
+reallocated to increase the size, it will grow in increments of
+C<Bufsize>.
+
+Default is 4096.
+
+=item B<-Dictionary>
+
+The default is no dictionary.
+
+=back
+
+Here is an example of using the C<inflateInit> optional parameter to
+override the default buffer size.
+
+ inflateInit( -Bufsize => 300 ) ;
+
+=head2 B<($out, $status) = $i-E<gt>inflate($buffer)>
+
+Inflates the complete contents of C<$buffer>. The buffer can either be
+a scalar or a scalar reference.
+
+Returns C<Z_OK> if successful and C<Z_STREAM_END> if the end of the
+compressed data has been successfully reached.
+If not successful, C<$out> will be I<undef> and C<$status> will hold
+the I<zlib> error code.
+
+The C<$buffer> parameter is modified by C<inflate>. On completion it
+will contain what remains of the input buffer after inflation. This
+means that C<$buffer> will be an empty string when the return status is
+C<Z_OK>. When the return status is C<Z_STREAM_END> the C<$buffer>
+parameter will contains what (if anything) was stored in the input
+buffer after the deflated data stream.
+
+This feature is useful when processing a file format that encapsulates
+a compressed data stream (e.g. gzip, zip).
+
+=head2 B<$status = $i-E<gt>inflateSync($buffer)>
+
+Scans C<$buffer> until it reaches either a I<full flush point> or the
+end of the buffer.
+
+If a I<full flush point> is found, C<Z_OK> is returned and C<$buffer>
+will be have all data up to the flush point removed. This can then be
+passed to the C<deflate> method.
+
+Any other return code means that a flush point was not found. If more
+data is available, C<inflateSync> can be called repeatedly with more
+compressed data until the flush point is found.
+
+=head2 B<$i-E<gt>dict_adler()>
+
+Returns the adler32 value for the dictionary.
+
+=head2 B<$i-E<gt>msg()>
+
+Returns the last error message generated by zlib.
+
+=head2 B<$i-E<gt>total_in()>
+
+Returns the total number of bytes compressed bytes input to inflate.
+
+=head2 B<$i-E<gt>total_out()>
+
+Returns the total number of uncompressed bytes output from inflate.
+
+=head2 Example
+
+Here is an example of using C<inflate>.
+
+ use strict ;
+ use warnings ;
+
+ use Compress::Zlib ;
+
+ my $x = inflateInit()
+ or die "Cannot create a inflation stream\n" ;
+
+ my $input = '' ;
+ binmode STDIN;
+ binmode STDOUT;
+
+ my ($output, $status) ;
+ while (read(STDIN, $input, 4096))
+ {
+ ($output, $status) = $x->inflate(\$input) ;
+
+ print $output
+ if $status == Z_OK or $status == Z_STREAM_END ;
+
+ last if $status != Z_OK ;
+ }
+
+ die "inflation failed\n"
+ unless $status == Z_STREAM_END ;
+
+=head1 CHECKSUM FUNCTIONS
+
+Two functions are provided by I<zlib> to calculate checksums. For the
+Perl interface, the order of the two parameters in both functions has
+been reversed. This allows both running checksums and one off
+calculations to be done.
+
+ $crc = adler32($buffer [,$crc]) ;
+ $crc = crc32($buffer [,$crc]) ;
+
+The buffer parameters can either be a scalar or a scalar reference.
+
+If the $crc parameters is C<undef>, the crc value will be reset.
+
+If you have built this module with zlib 1.2.3 or better, two more
+CRC-related functions are available.
+
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
+
+These functions allow checksums to be merged.
+
+=head1 Misc
+
+=head2 my $version = Compress::Zlib::zlib_version();
+
+Returns the version of the zlib library.
+
+=head1 CONSTANTS
+
+All the I<zlib> constants are automatically imported when you make use
+of I<Compress::Zlib>.
+
+=head1 SEE ALSO
+
+L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 1995-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/Config/Extensions.pm b/Master/tlpkg/tlperl/lib/Config/Extensions.pm
new file mode 100644
index 00000000000..82fb9e09e89
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config/Extensions.pm
@@ -0,0 +1,63 @@
+package Config::Extensions;
+use strict;
+use vars qw(%Extensions $VERSION @ISA @EXPORT_OK);
+use Config;
+require Exporter;
+
+$VERSION = '0.01';
+@ISA = 'Exporter';
+@EXPORT_OK = '%Extensions';
+
+foreach my $type (qw(static dynamic nonxs)) {
+ foreach (split /\s+/, $Config{$type . '_ext'}) {
+ s!/!::!g;
+ $Extensions{$_} = $type;
+ }
+}
+
+1;
+__END__
+=head1 NAME
+
+Config::Extensions - hash lookup of which core extensions were built.
+
+=head1 SYNOPSIS
+
+ use Config::Extensions '%Extensions';
+ if ($Extensions{PerlIO::via}) {
+ # This perl has PerlIO::via built
+ }
+
+=head1 DESCRIPTION
+
+The Config::Extensions module provides a hash C<%Extensions> containing all
+the core extensions that were enabled for this perl. The hash is keyed by
+extension name, with each entry having one of 3 possible values:
+
+=over 4
+
+=item dynamic
+
+The extension is dynamically linked
+
+=item nonxs
+
+The extension is pure perl, so doesn't need linking to the perl executable
+
+=item static
+
+The extension is statically linked to the perl binary
+
+=back
+
+As all values evaluate to true, a simple C<if> test is good enough to determine
+whether an extension is present.
+
+All the data uses to generate the C<%Extensions> hash is already present in
+the C<Config> module, but not in such a convenient format to quickly reference.
+
+=head1 AUTHOR
+
+Nicholas Clark <nick@ccl4.org>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm b/Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm
new file mode 100644
index 00000000000..b9f7dea92bf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm
@@ -0,0 +1,53 @@
+package DBM_Filter::compress ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.02';
+
+BEGIN
+{
+ eval { require Compress::Zlib; Compress::Zlib->import() };
+
+ croak "Compress::Zlib module not found.\n"
+ if $@;
+}
+
+
+
+sub Store { $_ = compress($_) }
+sub Fetch { $_ = uncompress($_) }
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter::compress - filter for DBM_Filter
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('compress');
+
+=head1 DESCRIPTION
+
+This DBM filter will compress all data before it is written to the database
+and uncompressed it on reading.
+
+A fatal error will be thrown if the Compress::Zlib module is not
+available.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Compress::Zlib>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm b/Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm
new file mode 100644
index 00000000000..fedb6928116
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm
@@ -0,0 +1,86 @@
+package DBM_Filter::encode ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.02';
+
+BEGIN
+{
+ eval { require Encode; };
+
+ croak "Encode module not found.\n"
+ if $@;
+}
+
+
+sub Filter
+{
+ my $encoding_name = shift || "utf8";
+
+ my $encoding = Encode::find_encoding($encoding_name) ;
+
+ croak "Encoding '$encoding_name' is not available"
+ unless $encoding;
+
+ return {
+ Store => sub {
+ $_ = $encoding->encode($_)
+ if defined $_ ;
+ },
+ Fetch => sub {
+ $_ = $encoding->decode($_)
+ if defined $_ ;
+ }
+ } ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter::encode - filter for DBM_Filter
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('encode' => 'iso-8859-16');
+
+=head1 DESCRIPTION
+
+This DBM filter allows you to choose the character encoding will be
+store in the DBM file. The usage is
+
+ $db->Filter_Push('encode' => ENCODING);
+
+where "ENCODING" must be a valid encoding name that the Encode module
+recognises.
+
+A fatal error will be thrown if:
+
+=over 5
+
+=item 1
+
+The Encode module is not available.
+
+=item 2
+
+The encoding requested is not supported by the Encode module.
+
+=back
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Encode>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm b/Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm
new file mode 100644
index 00000000000..d8fa5424af4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm
@@ -0,0 +1,50 @@
+package DBM_Filter::int32 ;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+# todo get Filter to figure endian.
+
+sub Store
+{
+ $_ = 0 if ! defined $_ || $_ eq "" ;
+ $_ = pack("i", $_);
+}
+
+sub Fetch
+{
+ no warnings 'uninitialized';
+ $_ = unpack("i", $_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter::int32 - filter for DBM_Filter
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('int32');
+
+=head1 DESCRIPTION
+
+This DBM filter is used when interoperating with a C/C++ application
+that uses a C int as either the key and/or value in the DBM file.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter/null.pm b/Master/tlpkg/tlperl/lib/DBM_Filter/null.pm
new file mode 100644
index 00000000000..ffa10e92f21
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter/null.pm
@@ -0,0 +1,52 @@
+package DBM_Filter::null ;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+sub Store
+{
+ no warnings 'uninitialized';
+ $_ .= "\x00" ;
+}
+
+sub Fetch
+{
+ no warnings 'uninitialized';
+ s/\x00$// ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter::null - filter for DBM_Filter
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('null');
+
+=head1 DESCRIPTION
+
+This filter ensures that all data written to the DBM file is null
+terminated. This is useful when you have a perl script that needs
+to interoperate with a DBM file that a C program also uses. A fairly
+common issue is for the C application to include the terminating null
+in a string when it writes to the DBM file. This filter will ensure that
+all data written to the DBM file can be read by the C application.
+
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm b/Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm
new file mode 100644
index 00000000000..677e66156b6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm
@@ -0,0 +1,51 @@
+package DBM_Filter::utf8 ;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.02';
+
+BEGIN
+{
+ eval { require Encode; };
+
+ croak "Encode module not found.\n"
+ if $@;
+}
+
+sub Store { $_ = Encode::encode_utf8($_) if defined $_ }
+
+sub Fetch { $_ = Encode::decode_utf8($_) if defined $_ }
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter::utf8 - filter for DBM_Filter
+
+=head1 SYNOPSIS
+
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+ use DBM_Filter ;
+
+ $db = tie %hash, ...
+ $db->Filter_Push('utf8');
+
+=head1 DESCRIPTION
+
+This Filter will ensure that all data written to the DBM will be encoded
+in UTF-8.
+
+This module uses the Encode module.
+
+=head1 SEE ALSO
+
+L<DBM_Filter>, L<perldbmfilter>, L<Encode>
+
+=head1 AUTHOR
+
+Paul Marquess pmqs@cpan.org
+
diff --git a/Master/tlpkg/tlperl/lib/Data/Dumper.pm b/Master/tlpkg/tlperl/lib/Data/Dumper.pm
new file mode 100644
index 00000000000..0eb8bf74fd6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Data/Dumper.pm
@@ -0,0 +1,1306 @@
+#
+# Data/Dumper.pm
+#
+# convert perl data structures into perl syntax suitable for both printing
+# and eval
+#
+# Documentation at the __END__
+#
+
+package Data::Dumper;
+
+$VERSION = '2.125'; # Don't forget to set version and release date in POD!
+
+#$| = 1;
+
+use 5.006_001;
+require Exporter;
+require overload;
+
+use Carp;
+
+BEGIN {
+ @ISA = qw(Exporter);
+ @EXPORT = qw(Dumper);
+ @EXPORT_OK = qw(DumperX);
+
+ # if run under miniperl, or otherwise lacking dynamic loading,
+ # XSLoader should be attempted to load, or the pure perl flag
+ # toggled on load failure.
+ eval {
+ require XSLoader;
+ };
+ $Useperl = 1 if $@;
+}
+
+XSLoader::load( 'Data::Dumper' ) unless $Useperl;
+
+# module vars and their defaults
+$Indent = 2 unless defined $Indent;
+$Purity = 0 unless defined $Purity;
+$Pad = "" unless defined $Pad;
+$Varname = "VAR" unless defined $Varname;
+$Useqq = 0 unless defined $Useqq;
+$Terse = 0 unless defined $Terse;
+$Freezer = "" unless defined $Freezer;
+$Toaster = "" unless defined $Toaster;
+$Deepcopy = 0 unless defined $Deepcopy;
+$Quotekeys = 1 unless defined $Quotekeys;
+$Bless = "bless" unless defined $Bless;
+#$Expdepth = 0 unless defined $Expdepth;
+$Maxdepth = 0 unless defined $Maxdepth;
+$Pair = ' => ' unless defined $Pair;
+$Useperl = 0 unless defined $Useperl;
+$Sortkeys = 0 unless defined $Sortkeys;
+$Deparse = 0 unless defined $Deparse;
+
+#
+# expects an arrayref of values to be dumped.
+# can optionally pass an arrayref of names for the values.
+# names must have leading $ sign stripped. begin the name with *
+# to cause output of arrays and hashes rather than refs.
+#
+sub new {
+ my($c, $v, $n) = @_;
+
+ croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
+ unless (defined($v) && (ref($v) eq 'ARRAY'));
+ $n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
+
+ my($s) = {
+ level => 0, # current recursive depth
+ indent => $Indent, # various styles of indenting
+ pad => $Pad, # all lines prefixed by this string
+ xpad => "", # padding-per-level
+ apad => "", # added padding for hash keys n such
+ sep => "", # list separator
+ pair => $Pair, # hash key/value separator: defaults to ' => '
+ seen => {}, # local (nested) refs (id => [name, val])
+ todump => $v, # values to dump []
+ names => $n, # optional names for values []
+ varname => $Varname, # prefix to use for tagging nameless ones
+ purity => $Purity, # degree to which output is evalable
+ useqq => $Useqq, # use "" for strings (backslashitis ensues)
+ terse => $Terse, # avoid name output (where feasible)
+ freezer => $Freezer, # name of Freezer method for objects
+ toaster => $Toaster, # name of method to revive objects
+ deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion
+ quotekeys => $Quotekeys, # quote hash keys
+ 'bless' => $Bless, # keyword to use for "bless"
+# expdepth => $Expdepth, # cutoff depth for explicit dumping
+ maxdepth => $Maxdepth, # depth beyond which we give up
+ useperl => $Useperl, # use the pure Perl implementation
+ sortkeys => $Sortkeys, # flag or filter for sorting hash keys
+ deparse => $Deparse, # use B::Deparse for coderefs
+ };
+
+ if ($Indent > 0) {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ return bless($s, $c);
+}
+
+if ($] >= 5.008) {
+ # Packed numeric addresses take less memory. Plus pack is faster than sprintf
+ *init_refaddr_format = sub {};
+
+ *format_refaddr = sub {
+ require Scalar::Util;
+ pack "J", Scalar::Util::refaddr(shift);
+ };
+} else {
+ *init_refaddr_format = sub {
+ require Config;
+ my $f = $Config::Config{uvxformat};
+ $f =~ tr/"//d;
+ our $refaddr_format = "0x%" . $f;
+ };
+
+ *format_refaddr = sub {
+ require Scalar::Util;
+ sprintf our $refaddr_format, Scalar::Util::refaddr(shift);
+ }
+}
+
+#
+# add-to or query the table of already seen references
+#
+sub Seen {
+ my($s, $g) = @_;
+ if (defined($g) && (ref($g) eq 'HASH')) {
+ init_refaddr_format();
+ my($k, $v, $id);
+ while (($k, $v) = each %$g) {
+ if (defined $v and ref $v) {
+ $id = format_refaddr($v);
+ if ($k =~ /^[*](.*)$/) {
+ $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
+ (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
+ (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ elsif ($k !~ /^\$/) {
+ $k = "\$" . $k;
+ }
+ $s->{seen}{$id} = [$k, $v];
+ }
+ else {
+ carp "Only refs supported, ignoring non-ref item \$$k";
+ }
+ }
+ return $s;
+ }
+ else {
+ return map { @$_ } values %{$s->{seen}};
+ }
+}
+
+#
+# set or query the values to be dumped
+#
+sub Values {
+ my($s, $v) = @_;
+ if (defined($v) && (ref($v) eq 'ARRAY')) {
+ $s->{todump} = [@$v]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{todump}};
+ }
+}
+
+#
+# set or query the names of the values to be dumped
+#
+sub Names {
+ my($s, $n) = @_;
+ if (defined($n) && (ref($n) eq 'ARRAY')) {
+ $s->{names} = [@$n]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{names}};
+ }
+}
+
+sub DESTROY {}
+
+sub Dump {
+ return &Dumpxs
+ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
+ $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) ||
+ $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
+ return &Dumpperl;
+}
+
+#
+# dump the refs in the current dumper object.
+# expects same args as new() if called via package name.
+#
+sub Dumpperl {
+ my($s) = shift;
+ my(@out, $val, $name);
+ my($i) = 0;
+ local(@post);
+ init_refaddr_format();
+
+ $s = $s->new(@_) unless ref $s;
+
+ for $val (@{$s->{todump}}) {
+ my $out = "";
+ @post = ();
+ $name = $s->{names}[$i++];
+ if (defined $name) {
+ if ($name =~ /^[*](.*)$/) {
+ if (defined $val) {
+ $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
+ (ref $val eq 'HASH') ? ( "\%" . $1 ) :
+ (ref $val eq 'CODE') ? ( "\*" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ else {
+ $name = "\$" . $1;
+ }
+ }
+ elsif ($name !~ /^\$/) {
+ $name = "\$" . $name;
+ }
+ }
+ else {
+ $name = "\$" . $s->{varname} . $i;
+ }
+
+ my $valstr;
+ {
+ local($s->{apad}) = $s->{apad};
+ $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
+ $valstr = $s->_dump($val, $name);
+ }
+
+ $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
+ $out .= $s->{pad} . $valstr . $s->{sep};
+ $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post)
+ . ';' . $s->{sep} if @post;
+
+ push @out, $out;
+ }
+ return wantarray ? @out : join('', @out);
+}
+
+# wrap string in single quotes (escaping if needed)
+sub _quote {
+ my $val = shift;
+ $val =~ s/([\\\'])/\\$1/g;
+ return "'" . $val . "'";
+}
+
+#
+# twist, toil and turn;
+# and recurse, of course.
+# sometimes sordidly;
+# and curse if no recourse.
+#
+sub _dump {
+ my($s, $val, $name) = @_;
+ my($sname);
+ my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
+
+ $type = ref $val;
+ $out = "";
+
+ if ($type) {
+
+ # Call the freezer method if it's specified and the object has the
+ # method. Trap errors and warn() instead of die()ing, like the XS
+ # implementation.
+ my $freezer = $s->{freezer};
+ if ($freezer and UNIVERSAL::can($val, $freezer)) {
+ eval { $val->$freezer() };
+ warn "WARNING(Freezer method call failed): $@" if $@;
+ }
+
+ require Scalar::Util;
+ $realpack = Scalar::Util::blessed($val);
+ $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
+ $id = format_refaddr($val);
+
+ # if it has a name, we need to either look it up, or keep a tab
+ # on it so we know when we hit it later
+ if (defined($name) and length($name)) {
+ # keep a tab on it so that we dont fall into recursive pit
+ if (exists $s->{seen}{$id}) {
+# if ($s->{expdepth} < $s->{level}) {
+ if ($s->{purity} and $s->{level} > 0) {
+ $out = ($realtype eq 'HASH') ? '{}' :
+ ($realtype eq 'ARRAY') ? '[]' :
+ 'do{my $o}' ;
+ push @post, $name . " = " . $s->{seen}{$id}[0];
+ }
+ else {
+ $out = $s->{seen}{$id}[0];
+ if ($name =~ /^([\@\%])/) {
+ my $start = $1;
+ if ($out =~ /^\\$start/) {
+ $out = substr($out, 1);
+ }
+ else {
+ $out = $start . '{' . $out . '}';
+ }
+ }
+ }
+ return $out;
+# }
+ }
+ else {
+ # store our name
+ $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
+ ($realtype eq 'CODE' and
+ $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
+ $name ),
+ $val ];
+ }
+ }
+ my $no_bless = 0;
+ my $is_regex = 0;
+ if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
+ $is_regex = 1;
+ $no_bless = $realpack eq 'Regexp';
+ }
+
+ # If purity is not set and maxdepth is set, then check depth:
+ # if we have reached maximum depth, return the string
+ # representation of the thing we are currently examining
+ # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
+ if (!$s->{purity}
+ and $s->{maxdepth} > 0
+ and $s->{level} >= $s->{maxdepth})
+ {
+ return qq['$val'];
+ }
+
+ # we have a blessed ref
+ if ($realpack and !$no_bless) {
+ $out = $s->{'bless'} . '( ';
+ $blesspad = $s->{apad};
+ $s->{apad} .= ' ' if ($s->{indent} >= 2);
+ }
+
+ $s->{level}++;
+ $ipad = $s->{xpad} x $s->{level};
+
+ if ($is_regex) {
+ my $pat;
+ # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
+ # universal.c, and even worse we cant just require that re to be loaded
+ # we *have* to use() it.
+ # We should probably move it to universal.c for 5.10.1 and fix this.
+ # Currently we only use re::regexp_pattern when the re is blessed into another
+ # package. This has the disadvantage of meaning that a DD dump won't round trip
+ # as the pattern will be repeatedly wrapped with the same modifiers.
+ # This is an aesthetic issue so we will leave it for now, but we could use
+ # regexp_pattern() in list context to get the modifiers separately.
+ # But since this means loading the full debugging engine in process we wont
+ # bother unless its necessary for accuracy.
+ if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
+ $pat = re::regexp_pattern($val);
+ } else {
+ $pat = "$val";
+ }
+ $pat =~ s,/,\\/,g;
+ $out .= "qr/$pat/";
+ }
+ elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
+ if ($realpack) {
+ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
+ }
+ else {
+ $out .= '\\' . $s->_dump($$val, "\${$name}");
+ }
+ }
+ elsif ($realtype eq 'GLOB') {
+ $out .= '\\' . $s->_dump($$val, "*{$name}");
+ }
+ elsif ($realtype eq 'ARRAY') {
+ my($pad, $mname);
+ my($i) = 0;
+ $out .= ($name =~ /^\@/) ? '(' : '[';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ for my $v (@$val) {
+ $sname = $mname . '[' . $i . ']';
+ $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
+ $out .= $pad . $ipad . $s->_dump($v, $sname);
+ $out .= "," if $i++ < $#$val;
+ }
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
+ $out .= ($name =~ /^\@/) ? ')' : ']';
+ }
+ elsif ($realtype eq 'HASH') {
+ my($k, $v, $pad, $lpad, $mname, $pair);
+ $out .= ($name =~ /^\%/) ? '(' : '{';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ $lpad = $s->{apad};
+ $pair = $s->{pair};
+ ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
+ if ($sortkeys) {
+ if (ref($s->{sortkeys}) eq 'CODE') {
+ $keys = $s->{sortkeys}($val);
+ unless (ref($keys) eq 'ARRAY') {
+ carp "Sortkeys subroutine did not return ARRAYREF";
+ $keys = [];
+ }
+ }
+ else {
+ $keys = [ sort keys %$val ];
+ }
+ }
+
+ # Ensure hash iterator is reset
+ keys(%$val);
+
+ while (($k, $v) = ! $sortkeys ? (each %$val) :
+ @$keys ? ($key = shift(@$keys), $val->{$key}) :
+ () )
+ {
+ my $nk = $s->_dump($k, "");
+ $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
+ $sname = $mname . '{' . $nk . '}';
+ $out .= $pad . $ipad . $nk . $pair;
+
+ # temporarily alter apad
+ $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
+ $out .= $s->_dump($val->{$k}, $sname) . ",";
+ $s->{apad} = $lpad if $s->{indent} >= 2;
+ }
+ if (substr($out, -1) eq ',') {
+ chop $out;
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
+ }
+ $out .= ($name =~ /^\%/) ? ')' : '}';
+ }
+ elsif ($realtype eq 'CODE') {
+ if ($s->{deparse}) {
+ require B::Deparse;
+ my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
+ $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
+ $sub =~ s/\n/$pad/gse;
+ $out .= $sub;
+ } else {
+ $out .= 'sub { "DUMMY" }';
+ carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
+ }
+ }
+ else {
+ croak "Can\'t handle $realtype type.";
+ }
+
+ if ($realpack and !$no_bless) { # we have a blessed ref
+ $out .= ', ' . _quote($realpack) . ' )';
+ $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne '';
+ $s->{apad} = $blesspad;
+ }
+ $s->{level}--;
+
+ }
+ else { # simple scalar
+
+ my $ref = \$_[1];
+ # first, catalog the scalar
+ if ($name ne '') {
+ $id = format_refaddr($ref);
+ if (exists $s->{seen}{$id}) {
+ if ($s->{seen}{$id}[2]) {
+ $out = $s->{seen}{$id}[0];
+ #warn "[<$out]\n";
+ return "\${$out}";
+ }
+ }
+ else {
+ #warn "[>\\$name]\n";
+ $s->{seen}{$id} = ["\\$name", $ref];
+ }
+ }
+ if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob
+ my $name = substr($val, 1);
+ if ($name =~ /^[A-Za-z_][\w:]*$/) {
+ $name =~ s/^main::/::/;
+ $sname = $name;
+ }
+ else {
+ $sname = $s->_dump($name, "");
+ $sname = '{' . $sname . '}';
+ }
+ if ($s->{purity}) {
+ my $k;
+ local ($s->{level}) = 0;
+ for $k (qw(SCALAR ARRAY HASH)) {
+ my $gval = *$val{$k};
+ next unless defined $gval;
+ next if $k eq "SCALAR" && ! defined $$gval; # always there
+
+ # _dump can push into @post, so we hold our place using $postlen
+ my $postlen = scalar @post;
+ $post[$postlen] = "\*$sname = ";
+ local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
+ $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
+ }
+ }
+ $out .= '*' . $sname;
+ }
+ elsif (!defined($val)) {
+ $out .= "undef";
+ }
+ elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
+ $out .= $val;
+ }
+ else { # string
+ if ($s->{useqq} or $val =~ tr/\0-\377//c) {
+ # Fall back to qq if there's Unicode
+ $out .= qquote($val, $s->{useqq});
+ }
+ else {
+ $out .= _quote($val);
+ }
+ }
+ }
+ if ($id) {
+ # if we made it this far, $id was added to seen list at current
+ # level, so remove it to get deep copies
+ if ($s->{deepcopy}) {
+ delete($s->{seen}{$id});
+ }
+ elsif ($name) {
+ $s->{seen}{$id}[2] = 1;
+ }
+ }
+ return $out;
+}
+
+#
+# non-OO style of earlier version
+#
+sub Dumper {
+ return Data::Dumper->Dump([@_]);
+}
+
+# compat stub
+sub DumperX {
+ return Data::Dumper->Dumpxs([@_], []);
+}
+
+sub Dumpf { return Data::Dumper->Dump(@_) }
+
+sub Dumpp { print Data::Dumper->Dump(@_) }
+
+#
+# reset the "seen" cache
+#
+sub Reset {
+ my($s) = shift;
+ $s->{seen} = {};
+ return $s;
+}
+
+sub Indent {
+ my($s, $v) = @_;
+ if (defined($v)) {
+ if ($v == 0) {
+ $s->{xpad} = "";
+ $s->{sep} = "";
+ }
+ else {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ $s->{indent} = $v;
+ return $s;
+ }
+ else {
+ return $s->{indent};
+ }
+}
+
+sub Pair {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
+}
+
+sub Pad {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
+}
+
+sub Varname {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
+}
+
+sub Purity {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
+}
+
+sub Useqq {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
+}
+
+sub Terse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
+}
+
+sub Freezer {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
+}
+
+sub Toaster {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
+}
+
+sub Deepcopy {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
+}
+
+sub Quotekeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
+}
+
+sub Bless {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
+}
+
+sub Maxdepth {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
+}
+
+sub Useperl {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
+}
+
+sub Sortkeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
+}
+
+sub Deparse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
+}
+
+# used by qquote below
+my %esc = (
+ "\a" => "\\a",
+ "\b" => "\\b",
+ "\t" => "\\t",
+ "\n" => "\\n",
+ "\f" => "\\f",
+ "\r" => "\\r",
+ "\e" => "\\e",
+);
+
+# put a string value in double quotes
+sub qquote {
+ local($_) = shift;
+ s/([\\\"\@\$])/\\$1/g;
+ my $bytes; { use bytes; $bytes = length }
+ s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
+ return qq("$_") unless
+ /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit
+
+ my $high = shift || "";
+ s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
+
+ if (ord('^')==94) { # ascii
+ # no need for 3 digits in escape for these
+ s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
+ s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
+ # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
+ if ($high eq "iso8859") {
+ s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
+ } elsif ($high eq "utf8") {
+# use utf8;
+# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ } elsif ($high eq "8bit") {
+ # leave it as it is
+ } else {
+ s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ }
+ }
+ else { # ebcdic
+ s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
+ {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
+ s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
+ {'\\'.sprintf('%03o',ord($1))}eg;
+ }
+
+ return qq("$_");
+}
+
+# helper sub to sort hash keys in Perl < 5.8.0 where we don't have
+# access to sortsv() from XS
+sub _sortkeys { [ sort keys %{$_[0]} ] }
+
+1;
+__END__
+
+=head1 NAME
+
+Data::Dumper - stringified perl data structures, suitable for both printing and C<eval>
+
+=head1 SYNOPSIS
+
+ use Data::Dumper;
+
+ # simple procedural interface
+ print Dumper($foo, $bar);
+
+ # extended usage with names
+ print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+
+ # configuration variables
+ {
+ local $Data::Dumper::Purity = 1;
+ eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+ }
+
+ # OO usage
+ $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]);
+ ...
+ print $d->Dump;
+ ...
+ $d->Purity(1)->Terse(1)->Deepcopy(1);
+ eval $d->Dump;
+
+
+=head1 DESCRIPTION
+
+Given a list of scalars or reference variables, writes out their contents in
+perl syntax. The references can also be objects. The content of each
+variable is output in a single Perl statement. Handles self-referential
+structures correctly.
+
+The return value can be C<eval>ed to get back an identical copy of the
+original reference structure.
+
+Any references that are the same as one of those passed in will be named
+C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
+to substructures within C<$VAR>I<n> will be appropriately labeled using arrow
+notation. You can specify names for individual values to be dumped if you
+use the C<Dump()> method, or you can change the default C<$VAR> prefix to
+something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse>
+below.
+
+The default output of self-referential structures can be C<eval>ed, but the
+nested references to C<$VAR>I<n> will be undefined, since a recursive
+structure cannot be constructed using one Perl statement. You should set the
+C<Purity> flag to 1 to get additional statements that will correctly fill in
+these references. Moreover, if C<eval>ed when strictures are in effect,
+you need to ensure that any variables it accesses are previously declared.
+
+In the extended usage form, the references to be dumped can be given
+user-specified names. If a name begins with a C<*>, the output will
+describe the dereferenced type of the supplied reference for hashes and
+arrays, and coderefs. Output of names will be avoided where possible if
+the C<Terse> flag is set.
+
+In many cases, methods that are used to set the internal state of the
+object will return the object itself, so method calls can be conveniently
+chained together.
+
+Several styles of output are possible, all controlled by setting
+the C<Indent> flag. See L<Configuration Variables or Methods> below
+for details.
+
+
+=head2 Methods
+
+=over 4
+
+=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns a newly created C<Data::Dumper> object. The first argument is an
+anonymous array of values to be dumped. The optional second argument is an
+anonymous array of names for the values. The names need not have a leading
+C<$> sign, and must be comprised of alphanumeric characters. You can begin
+a name with a C<*> to specify that the dereferenced type must be dumped
+instead of the reference itself, for ARRAY and HASH references.
+
+The prefix specified by C<$Data::Dumper::Varname> will be used with a
+numeric suffix if the name for a value is undefined.
+
+Data::Dumper will catalog all references encountered while dumping the
+values. Cross-references (in the form of names of substructures in perl
+syntax) will be inserted at all possible points, preserving any structural
+interdependencies in the original set of values. Structure traversal is
+depth-first, and proceeds in order from the first supplied value to
+the last.
+
+=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns the stringified form of the values stored in the object (preserving
+the order in which they were supplied to C<new>), subject to the
+configuration options below. In a list context, it returns a list
+of strings corresponding to the supplied values.
+
+The second form, for convenience, simply calls the C<new> method on its
+arguments before dumping the object immediately.
+
+=item I<$OBJ>->Seen(I<[HASHREF]>)
+
+Queries or adds to the internal table of already encountered references.
+You must use C<Reset> to explicitly clear the table if needed. Such
+references are not dumped; instead, their names are inserted wherever they
+are encountered subsequently. This is useful especially for properly
+dumping subroutine references.
+
+Expects an anonymous hash of name => value pairs. Same rules apply for names
+as in C<new>. If no argument is supplied, will return the "seen" list of
+name => value pairs, in a list context. Otherwise, returns the object
+itself.
+
+=item I<$OBJ>->Values(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of values that will be dumped.
+When called without arguments, returns the values. Otherwise, returns the
+object itself.
+
+=item I<$OBJ>->Names(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of user supplied names for the values
+that will be dumped. When called without arguments, returns the names.
+Otherwise, returns the object itself.
+
+=item I<$OBJ>->Reset
+
+Clears the internal table of "seen" references and returns the object
+itself.
+
+=back
+
+=head2 Functions
+
+=over 4
+
+=item Dumper(I<LIST>)
+
+Returns the stringified form of the values in the list, subject to the
+configuration options below. The values will be named C<$VAR>I<n> in the
+output, where I<n> is a numeric suffix. Will return a list of strings
+in a list context.
+
+=back
+
+=head2 Configuration Variables or Methods
+
+Several configuration variables can be used to control the kind of output
+generated when using the procedural interface. These variables are usually
+C<local>ized in a block so that other parts of the code are not affected by
+the change.
+
+These variables determine the default state of the object created by calling
+the C<new> method, but cannot be used to alter the state of the object
+thereafter. The equivalent method names should be used instead to query
+or set the internal state of the object.
+
+The method forms return the object itself when called with arguments,
+so that they can be chained together nicely.
+
+=over 4
+
+=item *
+
+$Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>)
+
+Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0
+spews output without any newlines, indentation, or spaces between list
+items. It is the most compact format possible that can still be called
+valid perl. Style 1 outputs a readable form with newlines but no fancy
+indentation (each level in the structure is simply indented by a fixed
+amount of whitespace). Style 2 (the default) outputs a very readable form
+which takes into account the length of hash keys (so the hash value lines
+up). Style 3 is like style 2, but also annotates the elements of arrays
+with their index (but the comment is on its own line, so array output
+consumes twice the number of lines). Style 2 is the default.
+
+=item *
+
+$Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>)
+
+Controls the degree to which the output can be C<eval>ed to recreate the
+supplied reference structures. Setting it to 1 will output additional perl
+statements that will correctly recreate nested references. The default is
+0.
+
+=item *
+
+$Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>)
+
+Specifies the string that will be prefixed to every line of the output.
+Empty string by default.
+
+=item *
+
+$Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>)
+
+Contains the prefix to use for tagging variable names in the output. The
+default is "VAR".
+
+=item *
+
+$Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>)
+
+When set, enables the use of double quotes for representing string values.
+Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
+characters will be backslashed, and unprintable characters will be output as
+quoted octal integers. Since setting this variable imposes a performance
+penalty, the default is 0. C<Dump()> will run slower if this flag is set,
+since the fast XSUB implementation doesn't support it yet.
+
+=item *
+
+$Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>)
+
+When set, Data::Dumper will emit single, non-self-referential values as
+atoms/terms rather than statements. This means that the C<$VAR>I<n> names
+will be avoided where possible, but be advised that such output may not
+always be parseable by C<eval>.
+
+=item *
+
+$Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will invoke that method via the object before attempting to
+stringify it. This method can alter the contents of the object (if, for
+instance, it contains data allocated from C), and even rebless it in a
+different package. The client is responsible for making sure the specified
+method can be called via the object, and that the object ends up containing
+only perl data types after the method has been called. Defaults to an empty
+string.
+
+If an object does not support the method specified (determined using
+UNIVERSAL::can()) then the call will be skipped. If the method dies a
+warning will be generated.
+
+=item *
+
+$Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will emit a method call for any objects that are to be dumped
+using the syntax C<bless(DATA, CLASS)-E<gt>METHOD()>. Note that this means that
+the method specified will have to perform any modifications required on the
+object (like creating new state within it, and/or reblessing it in a
+different package) and then return it. The client is responsible for making
+sure the method can be called via the object, and that it returns a valid
+object. Defaults to an empty string.
+
+=item *
+
+$Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>)
+
+Can be set to a boolean value to enable deep copies of structures.
+Cross-referencing will then only be done when absolutely essential
+(i.e., to break reference cycles). Default is 0.
+
+=item *
+
+$Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are quoted.
+A false value will avoid quoting hash keys when it looks like a simple
+string. Default is 1, which will always enclose hash keys in quotes.
+
+=item *
+
+$Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>)
+
+Can be set to a string that specifies an alternative to the C<bless>
+builtin operator used to create objects. A function with the specified
+name should exist, and should accept the same arguments as the builtin.
+Default is C<bless>.
+
+=item *
+
+$Data::Dumper::Pair I<or> $I<OBJ>->Pair(I<[NEWVAL]>)
+
+Can be set to a string that specifies the separator between hash keys
+and values. To dump nested hash, array and scalar values to JavaScript,
+use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript
+is left as an exercise for the reader.
+A function with the specified name exists, and accepts the same arguments
+as the builtin.
+
+Default is: C< =E<gt> >.
+
+=item *
+
+$Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>)
+
+Can be set to a positive integer that specifies the depth beyond which
+we don't venture into a structure. Has no effect when
+C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't
+want to see more than enough). Default is 0, which means there is
+no maximum depth.
+
+=item *
+
+$Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>)
+
+Can be set to a boolean value which controls whether the pure Perl
+implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is
+a dual implementation, with almost all functionality written in both
+pure Perl and also in XS ('C'). Since the XS version is much faster, it
+will always be used if possible. This option lets you override the
+default behavior, usually for testing purposes only. Default is 0, which
+means the XS implementation will be used if possible.
+
+=item *
+
+$Data::Dumper::Sortkeys I<or> $I<OBJ>->Sortkeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are dumped in
+sorted order. A true value will cause the keys of all hashes to be
+dumped in Perl's default sort order. Can also be set to a subroutine
+reference which will be called for each hash that is dumped. In this
+case C<Data::Dumper> will call the subroutine once for each hash,
+passing it the reference of the hash. The purpose of the subroutine is
+to return a reference to an array of the keys that will be dumped, in
+the order that they should be dumped. Using this feature, you can
+control both the order of the keys, and which keys are actually used. In
+other words, this subroutine acts as a filter by which you can exclude
+certain keys from being dumped. Default is 0, which means that hash keys
+are not sorted.
+
+=item *
+
+$Data::Dumper::Deparse I<or> $I<OBJ>->Deparse(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether code references are
+turned into perl source code. If set to a true value, C<B::Deparse>
+will be used to get the source of the code reference. Using this option
+will force using the Perl implementation of the dumper, since the fast
+XSUB implementation doesn't support it.
+
+Caution : use this option only if you know that your coderefs will be
+properly reconstructed by C<B::Deparse>.
+
+=back
+
+=head2 Exports
+
+=over 4
+
+=item Dumper
+
+=back
+
+=head1 EXAMPLES
+
+Run these code snippets to get a quick feel for the behavior of this
+module. When you are through with these examples, you may want to
+add or change the various configuration variables described above,
+to see their behavior. (See the testsuite in the Data::Dumper
+distribution for more examples.)
+
+
+ use Data::Dumper;
+
+ package Foo;
+ sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]};
+
+ package Fuz; # a weird REF-REF-SCALAR object
+ sub new {bless \($_ = \ 'fu\'z'), $_[0]};
+
+ package main;
+ $foo = Foo->new;
+ $fuz = Fuz->new;
+ $boo = [ 1, [], "abcd", \*foo,
+ {1 => 'a', 023 => 'b', 0x45 => 'c'},
+ \\"p\q\'r", $foo, $fuz];
+
+ ########
+ # simple usage
+ ########
+
+ $bar = eval(Dumper($boo));
+ print($@) if $@;
+ print Dumper($boo), Dumper($bar); # pretty print (no array indices)
+
+ $Data::Dumper::Terse = 1; # don't output names where feasible
+ $Data::Dumper::Indent = 0; # turn off all pretty print
+ print Dumper($boo), "\n";
+
+ $Data::Dumper::Indent = 1; # mild pretty print
+ print Dumper($boo);
+
+ $Data::Dumper::Indent = 3; # pretty print with array indices
+ print Dumper($boo);
+
+ $Data::Dumper::Useqq = 1; # print strings in double quotes
+ print Dumper($boo);
+
+ $Data::Dumper::Pair = " : "; # specify hash key/value separator
+ print Dumper($boo);
+
+
+ ########
+ # recursive structures
+ ########
+
+ @c = ('c');
+ $c = \@c;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);
+
+
+ $Data::Dumper::Purity = 1; # fill in the holes for eval
+ print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b
+
+
+ $Data::Dumper::Deepcopy = 1; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+
+ $Data::Dumper::Purity = 0; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+ ########
+ # deep structures
+ ########
+
+ $a = "pearl";
+ $b = [ $a ];
+ $c = { 'b' => $b };
+ $d = [ $c ];
+ $e = { 'd' => $d };
+ $f = { 'e' => $e };
+ print Data::Dumper->Dump([$f], [qw(f)]);
+
+ $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down
+ print Data::Dumper->Dump([$f], [qw(f)]);
+
+
+ ########
+ # object-oriented usage
+ ########
+
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c}); # stash a ref without printing it
+ $d->Indent(3);
+ print $d->Dump;
+ $d->Reset->Purity(0); # empty the seen cache
+ print join "----\n", $d->Dump;
+
+
+ ########
+ # persistence
+ ########
+
+ package Foo;
+ sub new { bless { state => 'awake' }, shift }
+ sub Freeze {
+ my $s = shift;
+ print STDERR "preparing to sleep\n";
+ $s->{state} = 'asleep';
+ return bless $s, 'Foo::ZZZ';
+ }
+
+ package Foo::ZZZ;
+ sub Thaw {
+ my $s = shift;
+ print STDERR "waking up\n";
+ $s->{state} = 'awake';
+ return bless $s, 'Foo';
+ }
+
+ package Foo;
+ use Data::Dumper;
+ $a = Foo->new;
+ $b = Data::Dumper->new([$a], ['c']);
+ $b->Freezer('Freeze');
+ $b->Toaster('Thaw');
+ $c = $b->Dump;
+ print $c;
+ $d = eval $c;
+ print Data::Dumper->Dump([$d], ['d']);
+
+
+ ########
+ # symbol substitution (useful for recreating CODE refs)
+ ########
+
+ sub foo { print "foo speaking\n" }
+ *other = \&foo;
+ $bar = [ \&other ];
+ $d = Data::Dumper->new([\&other,$bar],['*other','bar']);
+ $d->Seen({ '*foo' => \&foo });
+ print $d->Dump;
+
+
+ ########
+ # sorting and filtering hash keys
+ ########
+
+ $Data::Dumper::Sortkeys = \&my_filter;
+ my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' };
+ my $bar = { %$foo };
+ my $baz = { reverse %$foo };
+ print Dumper [ $foo, $bar, $baz ];
+
+ sub my_filter {
+ my ($hash) = @_;
+ # return an array ref containing the hash keys to dump
+ # in the order that you want them to be dumped
+ return [
+ # Sort the keys of %$foo in reverse numeric order
+ $hash eq $foo ? (sort {$b <=> $a} keys %$hash) :
+ # Only dump the odd number keys of %$bar
+ $hash eq $bar ? (grep {$_ % 2} keys %$hash) :
+ # Sort keys in default order for all other hashes
+ (sort keys %$hash)
+ ];
+ }
+
+=head1 BUGS
+
+Due to limitations of Perl subroutine call semantics, you cannot pass an
+array or hash. Prepend it with a C<\> to pass its reference instead. This
+will be remedied in time, now that Perl has subroutine prototypes.
+For now, you need to use the extended usage form, and prepend the
+name with a C<*> to output it as a hash or array.
+
+C<Data::Dumper> cheats with CODE references. If a code reference is
+encountered in the structure being processed (and if you haven't set
+the C<Deparse> flag), an anonymous subroutine that
+contains the string '"DUMMY"' will be inserted in its place, and a warning
+will be printed if C<Purity> is set. You can C<eval> the result, but bear
+in mind that the anonymous sub that gets created is just a placeholder.
+Someday, perl will have a switch to cache-on-demand the string
+representation of a compiled piece of code, I hope. If you have prior
+knowledge of all the code refs that your data structures are likely
+to have, you can use the C<Seen> method to pre-seed the internal reference
+table and make the dumped output point to them, instead. See L</EXAMPLES>
+above.
+
+The C<Useqq> and C<Deparse> flags makes Dump() run slower, since the
+XSUB implementation does not support them.
+
+SCALAR objects have the weirdest looking C<bless> workaround.
+
+Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly
+only in Perl 5.8.0 and later.
+
+=head2 NOTE
+
+Starting from Perl 5.8.1 different runs of Perl will have different
+ordering of hash keys. The change was done for greater security,
+see L<perlsec/"Algorithmic Complexity Attacks">. This means that
+different runs of Perl will have different Data::Dumper outputs if
+the data contains hashes. If you need to have identical Data::Dumper
+outputs from different runs of Perl, use the environment variable
+PERL_HASH_SEED, see L<perlrun/PERL_HASH_SEED>. Using this restores
+the old (platform-specific) ordering: an even prettier solution might
+be to use the C<Sortkeys> filter of Data::Dumper.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 VERSION
+
+Version 2.125 (Aug 8 2009)
+
+=head1 SEE ALSO
+
+perl(1)
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf.pm b/Master/tlpkg/tlperl/lib/Devel/DProf.pm
new file mode 100644
index 00000000000..7405b78dcf7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf.pm
@@ -0,0 +1,238 @@
+use 5.006_001;
+
+=head1 NAME
+
+Devel::DProf - a Perl code profiler
+
+=head1 SYNOPSIS
+
+ perl -d:DProf test.pl
+
+=head1 DESCRIPTION
+
+The Devel::DProf package is a Perl code profiler. This will collect
+information on the execution time of a Perl script and of the subs in that
+script. This information can be used to determine which subroutines are
+using the most time and which subroutines are being called most often. This
+information can also be used to create an execution graph of the script,
+showing subroutine relationships.
+
+To profile a Perl script run the perl interpreter with the B<-d> debugging
+switch. The profiler uses the debugging hooks. So to profile script
+F<test.pl> the following command should be used:
+
+ perl -d:DProf test.pl
+
+When the script terminates (or when the output buffer is filled) the
+profiler will dump the profile information to a file called
+F<tmon.out>. A tool like I<dprofpp> can be used to interpret the
+information which is in that profile. The following command will
+print the top 15 subroutines which used the most time:
+
+ dprofpp
+
+To print an execution graph of the subroutines in the script use the
+following command:
+
+ dprofpp -T
+
+Consult L<dprofpp> for other options.
+
+=head1 PROFILE FORMAT
+
+The old profile is a text file which looks like this:
+
+ #fOrTyTwO
+ $hz=100;
+ $XS_VERSION='DProf 19970606';
+ # All values are given in HZ
+ $rrun_utime=2; $rrun_stime=0; $rrun_rtime=7
+ PART2
+ + 26 28 566822884 DynaLoader::import
+ - 26 28 566822884 DynaLoader::import
+ + 27 28 566822885 main::bar
+ - 27 28 566822886 main::bar
+ + 27 28 566822886 main::baz
+ + 27 28 566822887 main::bar
+ - 27 28 566822888 main::bar
+ [....]
+
+The first line is the magic number. The second line is the hertz value, or
+clock ticks, of the machine where the profile was collected. The third line
+is the name and version identifier of the tool which created the profile.
+The fourth line is a comment. The fifth line contains three variables
+holding the user time, system time, and realtime of the process while it was
+being profiled. The sixth line indicates the beginning of the sub
+entry/exit profile section.
+
+The columns in B<PART2> are:
+
+ sub entry(+)/exit(-) mark
+ app's user time at sub entry/exit mark, in ticks
+ app's system time at sub entry/exit mark, in ticks
+ app's realtime at sub entry/exit mark, in ticks
+ fully-qualified sub name, when possible
+
+With newer perls another format is used, which may look like this:
+
+ #fOrTyTwO
+ $hz=10000;
+ $XS_VERSION='DProf 19971213';
+ # All values are given in HZ
+ $over_utime=5917; $over_stime=0; $over_rtime=5917;
+ $over_tests=10000;
+ $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284;
+ $total_marks=6;
+
+ PART2
+ @ 406 0 406
+ & 2 main bar
+ + 2
+ @ 456 0 456
+ - 2
+ @ 1 0 1
+ & 3 main baz
+ + 3
+ @ 141 0 141
+ + 2
+ @ 141 0 141
+ - 2
+ @ 1 0 1
+ & 4 main foo
+ + 4
+ @ 142 0 142
+ + & Devel::DProf::write
+ @ 5 0 5
+ - & Devel::DProf::write
+
+(with high value of $ENV{PERL_DPROF_TICKS}).
+
+New C<$over_*> values show the measured overhead of making $over_tests
+calls to the profiler These values are used by the profiler to
+subtract the overhead from the runtimes.
+
+Lines starting with C<@> mark the amount of time passed since the
+previous C<@> line. The numbers following the C<@> are integer tick
+counts representing user, system, and real time. Divide these numbers
+by the $hz value in the header to get seconds.
+
+Lines starting with C<&> map subroutine identifiers (an integer) to
+subroutine packages and names. These should only occur once per
+subroutine.
+
+Lines starting with C<+> or C<-> mark normal entering and exit of
+subroutines. The number following is a reference to a subroutine
+identifier.
+
+Lines starting with C<*> mark where subroutines are entered by C<goto
+&subr>, but note that the return will still be marked as coming from
+the original sub. The sequence might look like this:
+
+ + 5
+ * 6
+ - 5
+
+Lines starting with C</> is like C<-> but mark where subroutines are
+exited by dying. Example:
+
+ + 5
+ + 6
+ / 6
+ / 5
+
+Finally you might find C<@> time stamp marks surrounded by C<+ &
+Devel::DProf::write> and C<- & Devel::DProf::write> lines. These 3
+lines are outputted when printing of the mark above actually consumed
+measurable time.
+
+=head1 AUTOLOAD
+
+When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the
+C<$AUTOLOAD> variable to find the real name of the sub being called. See
+L<perlsub/"Autoloading">.
+
+=head1 ENVIRONMENT
+
+C<PERL_DPROF_BUFFER> sets size of output buffer in words. Defaults to 2**14.
+
+C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where
+a replacement for times() is used. Defaults to the value of C<HZ> macro.
+
+C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file. If not set,
+defaults to tmon.out.
+
+=head1 BUGS
+
+Builtin functions cannot be measured by Devel::DProf.
+
+With a newer Perl DProf relies on the fact that the numeric slot of
+$DB::sub contains an address of a subroutine. Excessive manipulation
+of this variable may overwrite this slot, as in
+
+ $DB::sub = 'current_sub';
+ ...
+ $addr = $DB::sub + 0;
+
+will set this numeric slot to numeric value of the string
+C<current_sub>, i.e., to C<0>. This will cause a segfault on the exit
+from this subroutine. Note that the first assignment above does not
+change the numeric slot (it will I<mark> it as invalid, but will not
+write over it).
+
+Another problem is that if a subroutine exits using goto(LABEL),
+last(LABEL) or next(LABEL) then perl may crash or Devel::DProf will die
+with the error:
+
+ panic: Devel::DProf inconsistent subroutine return
+
+For example, this code will break under Devel::DProf:
+
+ sub foo {
+ last FOO;
+ }
+ FOO: {
+ foo();
+ }
+
+A pattern like this is used by Test::More's skip() function, for
+example. See L<perldiag> for more details.
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>.
+
+=head1 SEE ALSO
+
+L<perl>, L<dprofpp>, times(2)
+
+=cut
+
+# This sub is needed for calibration.
+package Devel::DProf;
+
+sub NONESUCH_noxs {
+ return $Devel::DProf::VERSION;
+}
+
+package DB;
+
+#
+# As of perl5.003_20, &DB::sub stub is not needed (some versions
+# even had problems if stub was redefined with XS version).
+#
+
+# disable DB single-stepping
+BEGIN { $single = 0; }
+
+# This sub is needed during startup.
+sub DB {
+# print "nonXS DBDB\n";
+}
+
+use XSLoader ();
+
+$Devel::DProf::VERSION = '20080331.00'; # this version not authorized by
+ # Dean Roehrich. See "Changes" file.
+
+XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/V.pm b/Master/tlpkg/tlperl/lib/Devel/DProf/V.pm
new file mode 100644
index 00000000000..e613f6f4410
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/V.pm
@@ -0,0 +1,63 @@
+package V;
+
+use Getopt::Std 'getopts';
+getopts('vp:d:');
+
+require Exporter;
+@ISA = 'Exporter';
+
+@EXPORT = qw( dprofpp $opt_v $results $expected report @results );
+@EXPORT_OK = qw( notok ok $num );
+
+$num = 0;
+$results = $expected = '';
+$perl = $opt_p || $^X;
+$dpp = $opt_d || '../../utils/dprofpp';
+$dpp .= '.com' if $^O eq 'VMS';
+
+print "\nperl: $perl\n" if $opt_v;
+if( ! -f $perl ){ die "Where's Perl?" }
+if( ! -f $dpp ) {
+ ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@;
+ die "Where's dprofpp?" if( ! -f $dpp );
+}
+
+sub dprofpp {
+ my $switches = shift;
+
+ open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n";
+ @results = <D>;
+ close D;
+
+ open( D, "<err" ) || warn "$0: Can't open: $!\n";
+ @err = <D>;
+ close D;
+ push( @results, @err ) if @err;
+
+ $results = qq{@results};
+ # ignore Loader (Dyna/Auto etc), leave newline
+ $results =~ s/^\w+Loader::import//;
+ $results =~ s/\n /\n/gm;
+ $results;
+}
+
+sub report {
+ $num = shift;
+ my $sub = shift;
+ my $x;
+
+ $x = &$sub;
+ $x ? &ok : &notok;
+}
+
+sub ok {
+ print "ok $num\n";
+}
+
+sub notok {
+ print "not ok $num\n";
+ print "\nResult\n{$results}\n";
+ print "Expected\n{$expected}\n";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test1_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test1_t
new file mode 100644
index 00000000000..d504cd55365
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test1_t
@@ -0,0 +1,18 @@
+sub foo {
+ print "in sub foo\n";
+ bar();
+}
+
+sub bar {
+ print "in sub bar\n";
+}
+
+sub baz {
+ print "in sub baz\n";
+ bar();
+ foo();
+}
+
+bar();
+baz();
+foo();
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test1_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test1_v
new file mode 100644
index 00000000000..542a503414e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test1_v
@@ -0,0 +1,24 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::baz
+ main::bar
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 1, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 2, sub { $expected eq $results };
+
+dprofpp( '-t' );
+report 3, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 4, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test2_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test2_t
new file mode 100644
index 00000000000..edc46c527e6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test2_t
@@ -0,0 +1,21 @@
+sub foo {
+ print "in sub foo\n";
+ bar();
+}
+
+sub bar {
+ print "in sub bar\n";
+}
+
+sub baz {
+ print "in sub baz\n";
+ bar();
+ bar();
+ bar();
+ foo();
+}
+
+bar();
+bar();
+baz();
+foo();
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test2_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test2_v
new file mode 100644
index 00000000000..8b775b31315
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test2_v
@@ -0,0 +1,36 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::bar
+main::baz
+ main::bar
+ main::bar
+ main::bar
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 5, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 6, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected =
+qq{main::bar (2x)
+main::baz
+ main::bar (3x)
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 7, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 8, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test3_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test3_t
new file mode 100644
index 00000000000..a5327f4d7ad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test3_t
@@ -0,0 +1,19 @@
+sub foo {
+ print "in sub foo\n";
+ exit(0);
+ bar();
+}
+
+sub bar {
+ print "in sub bar\n";
+}
+
+sub baz {
+ print "in sub baz\n";
+ bar();
+ foo();
+}
+
+bar();
+baz();
+foo();
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test3_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test3_v
new file mode 100644
index 00000000000..df7543e2b80
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test3_v
@@ -0,0 +1,29 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$e1 = $expected =
+qq{main::bar
+main::baz
+ main::bar
+ main::foo
+};
+report 9, sub { $expected eq $results };
+
+dprofpp('-TF');
+$e2 = $expected =
+qq{main::bar
+main::baz
+ main::bar
+ main::foo
+};
+report 10, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected = $e1;
+report 11, sub { 1 };
+
+dprofpp('-tF');
+$expected = $e2;
+report 12, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test4_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test4_t
new file mode 100644
index 00000000000..729968270aa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test4_t
@@ -0,0 +1,24 @@
+sub foo {
+ print "in sub foo\n";
+ bar();
+}
+
+sub bar {
+ print "in sub bar\n";
+}
+
+sub baz {
+ print "in sub baz\n";
+ bar();
+ bar();
+ bar();
+ foo();
+}
+
+bar();
+
+eval { fork };
+
+bar();
+baz();
+foo();
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test4_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test4_v
new file mode 100644
index 00000000000..d9677ff7853
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test4_v
@@ -0,0 +1,36 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::bar
+main::baz
+ main::bar
+ main::bar
+ main::bar
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 13, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 14, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected =
+qq{main::bar (2x)
+main::baz
+ main::bar (3x)
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 15, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 16, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test5_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test5_t
new file mode 100644
index 00000000000..0b1113757fd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test5_t
@@ -0,0 +1,25 @@
+# Test that dprof doesn't break
+# &bar; used as &bar(@_);
+
+sub foo1 {
+ print "in foo1(@_)\n";
+ bar(@_);
+}
+sub foo2 {
+ print "in foo2(@_)\n";
+ &bar;
+}
+sub bar {
+ print "in bar(@_)\n";
+ if( @_ > 0 ){
+ &yeppers;
+ }
+}
+sub yeppers {
+ print "rest easy\n";
+}
+
+
+&foo1( A );
+&foo2( B );
+
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test5_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test5_v
new file mode 100644
index 00000000000..9e9298c6896
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test5_v
@@ -0,0 +1,15 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::foo1
+ main::bar
+ main::yeppers
+main::foo2
+ main::bar
+ main::yeppers
+};
+report 17, sub { $expected eq $results };
+
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test6_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test6_t
new file mode 100644
index 00000000000..7b8bf4a722b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test6_t
@@ -0,0 +1,29 @@
+sub foo {
+ my $x;
+ my $y;
+ print "in sub foo\n";
+ for( $x = 1; $x < 100; ++$x ){
+ bar();
+ for( $y = 1; $y < 100; ++$y ){
+ }
+ }
+}
+
+sub bar {
+ my $x;
+ print "in sub bar\n";
+ for( $x = 1; $x < 100; ++$x ){
+ }
+ die "bar exiting";
+}
+
+sub baz {
+ print "in sub baz\n";
+ eval { bar(); };
+ eval { foo(); };
+}
+
+eval { bar(); };
+baz();
+eval { foo(); };
+
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test6_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test6_v
new file mode 100644
index 00000000000..2f651ea7945
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test6_v
@@ -0,0 +1,16 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::baz
+ main::bar
+ main::foo
+ main::bar
+main::foo
+ main::bar
+};
+report 18, sub { $expected eq $results };
+
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test7_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test7_t
new file mode 100644
index 00000000000..56dbfd341c4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test7_t
@@ -0,0 +1,9 @@
+BEGIN {
+ print "in BEGIN\n";
+}
+
+sub foo {
+ print "in sub foo\n";
+}
+
+foo();
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test7_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test7_v
new file mode 100644
index 00000000000..1d19fe5cd52
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test7_v
@@ -0,0 +1,10 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::BEGIN
+main::foo
+};
+report 19, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test8_t b/Master/tlpkg/tlperl/lib/Devel/DProf/test8_t
new file mode 100644
index 00000000000..6154c8a5307
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test8_t
@@ -0,0 +1,15 @@
+sub foo {
+ print "in sub foo\n";
+}
+
+sub bar {
+ print "in sub bar\n";
+ $^P -= 0x40;
+}
+
+foo();
+$^P -= 0x40;
+foo();
+$^P += 0x40;
+bar();
+$^P += 0x40;
diff --git a/Master/tlpkg/tlperl/lib/Devel/DProf/test8_v b/Master/tlpkg/tlperl/lib/Devel/DProf/test8_v
new file mode 100644
index 00000000000..d5de3087fea
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/DProf/test8_v
@@ -0,0 +1,11 @@
+# perl
+
+use V;
+
+dprofpp( '-t' );
+$expected =
+qq{main::foo (2x)
+main::bar
+};
+
+report 20, sub { $expected eq $results };
diff --git a/Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm b/Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm
new file mode 100644
index 00000000000..614a59a85e5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm
@@ -0,0 +1,128 @@
+package Devel::InnerPackage;
+
+use strict;
+use base qw(Exporter);
+use vars qw($VERSION @EXPORT_OK);
+
+$VERSION = '0.3';
+@EXPORT_OK = qw(list_packages);
+
+=pod
+
+=head1 NAME
+
+
+Devel::InnerPackage - find all the inner packages of a package
+
+=head1 SYNOPSIS
+
+ use Foo::Bar;
+ use Devel::InnerPackage qw(list_packages);
+
+ my @inner_packages = list_packages('Foo::Bar');
+
+
+=head1 DESCRIPTION
+
+
+Given a file like this
+
+
+ package Foo::Bar;
+
+ sub foo {}
+
+
+ package Foo::Bar::Quux;
+
+ sub quux {}
+
+ package Foo::Bar::Quirka;
+
+ sub quirka {}
+
+ 1;
+
+then
+
+ list_packages('Foo::Bar');
+
+will return
+
+ Foo::Bar::Quux
+ Foo::Bar::Quirka
+
+=head1 METHODS
+
+=head2 list_packages <package name>
+
+Return a list of all inner packages of that package.
+
+=cut
+
+sub list_packages {
+ my $pack = shift; $pack .= "::" unless $pack =~ m!::$!;
+
+ no strict 'refs';
+ my @packs;
+ my @stuff = grep !/^(main|)::$/, keys %{$pack};
+ for my $cand (grep /::$/, @stuff)
+ {
+ $cand =~ s!::$!!;
+ my @children = list_packages($pack.$cand);
+
+ push @packs, "$pack$cand" unless $cand =~ /^::/ ||
+ !__PACKAGE__->_loaded($pack.$cand); # or @children;
+ push @packs, @children;
+ }
+ return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs;
+}
+
+### XXX this is an inlining of the Class-Inspector->loaded()
+### method, but inlined to remove the dependency.
+sub _loaded {
+ my ($class, $name) = @_;
+
+ no strict 'refs';
+
+ # Handle by far the two most common cases
+ # This is very fast and handles 99% of cases.
+ return 1 if defined ${"${name}::VERSION"};
+ return 1 if defined @{"${name}::ISA"};
+
+ # Are there any symbol table entries other than other namespaces
+ foreach ( keys %{"${name}::"} ) {
+ next if substr($_, -2, 2) eq '::';
+ return 1 if defined &{"${name}::$_"};
+ }
+
+ # No functions, and it doesn't have a version, and isn't anything.
+ # As an absolute last resort, check for an entry in %INC
+ my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm';
+ return 1 if defined $INC{$filename};
+
+ '';
+}
+
+
+=head1 AUTHOR
+
+Simon Wistow <simon@thegestalt.org>
+
+=head1 COPYING
+
+Copyright, 2005 Simon Wistow
+
+Distributed under the same terms as Perl itself.
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+
+
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Devel/PPPort.pm b/Master/tlpkg/tlperl/lib/Devel/PPPort.pm
new file mode 100644
index 00000000000..5d786f12a50
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/PPPort.pm
@@ -0,0 +1,8269 @@
+################################################################################
+#
+# !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
+#
+# This file was automatically generated from the definition files in the
+# parts/inc/ subdirectory by PPPort_pm.PL. To learn more about how all this
+# works, please read the F<HACKERS> file that came with this distribution.
+#
+################################################################################
+#
+# Perl/Pollution/Portability
+#
+################################################################################
+#
+# $Revision: 65 $
+# $Author: mhx $
+# $Date: 2009/06/12 04:10:36 +0200 $
+#
+################################################################################
+#
+# Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
+# Version 2.x, Copyright (C) 2001, Paul Marquess.
+# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+=head1 NAME
+
+Devel::PPPort - Perl/Pollution/Portability
+
+=head1 SYNOPSIS
+
+ Devel::PPPort::WriteFile(); # defaults to ./ppport.h
+ Devel::PPPort::WriteFile('someheader.h');
+
+=head1 DESCRIPTION
+
+Perl's API has changed over time, gaining new features, new functions,
+increasing its flexibility, and reducing the impact on the C namespace
+environment (reduced pollution). The header file written by this module,
+typically F<ppport.h>, attempts to bring some of the newer Perl API
+features to older versions of Perl, so that you can worry less about
+keeping track of old releases, but users can still reap the benefit.
+
+C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
+only purpose is to write the F<ppport.h> C header file. This file
+contains a series of macros and, if explicitly requested, functions that
+allow XS modules to be built using older versions of Perl. Currently,
+Perl versions from 5.003 to 5.10.0 are supported.
+
+This module is used by C<h2xs> to write the file F<ppport.h>.
+
+=head2 Why use ppport.h?
+
+You should use F<ppport.h> in modern code so that your code will work
+with the widest range of Perl interpreters possible, without significant
+additional work.
+
+You should attempt older code to fully use F<ppport.h>, because the
+reduced pollution of newer Perl versions is an important thing. It's so
+important that the old polluting ways of original Perl modules will not be
+supported very far into the future, and your module will almost certainly
+break! By adapting to it now, you'll gain compatibility and a sense of
+having done the electronic ecology some good.
+
+=head2 How to use ppport.h
+
+Don't direct the users of your module to download C<Devel::PPPort>.
+They are most probably no XS writers. Also, don't make F<ppport.h>
+optional. Rather, just take the most recent copy of F<ppport.h> that
+you can find (e.g. by generating it with the latest C<Devel::PPPort>
+release from CPAN), copy it into your project, adjust your project to
+use it, and distribute the header along with your module.
+
+=head2 Running ppport.h
+
+But F<ppport.h> is more than just a C header. It's also a Perl script
+that can check your source code. It will suggest hints and portability
+notes, and can even make suggestions on how to change your code. You
+can run it like any other Perl program:
+
+ perl ppport.h [options] [files]
+
+It also has embedded documentation, so you can use
+
+ perldoc ppport.h
+
+to find out more about how to use it.
+
+=head1 FUNCTIONS
+
+=head2 WriteFile
+
+C<WriteFile> takes one optional argument. When called with one
+argument, it expects to be passed a filename. When called with
+no arguments, it defaults to the filename F<ppport.h>.
+
+The function returns a true value if the file was written successfully.
+Otherwise it returns a false value.
+
+=head1 COMPATIBILITY
+
+F<ppport.h> supports Perl versions from 5.003 to 5.10.0
+in threaded and non-threaded configurations.
+
+=head2 Provided Perl compatibility API
+
+The header file written by this module, typically F<ppport.h>, provides
+access to the following elements of the Perl API that is not available
+in older Perl releases:
+
+ _aMY_CXT
+ _pMY_CXT
+ aMY_CXT
+ aMY_CXT_
+ aTHX
+ aTHX_
+ aTHXR
+ aTHXR_
+ AvFILLp
+ boolSV
+ call_argv
+ call_method
+ call_pv
+ call_sv
+ ckWARN
+ CopFILE
+ CopFILE_set
+ CopFILEAV
+ CopFILEGV
+ CopFILEGV_set
+ CopFILESV
+ CopSTASH
+ CopSTASH_eq
+ CopSTASH_set
+ CopSTASHPV
+ CopSTASHPV_set
+ CopyD
+ CPERLscope
+ dAX
+ dAXMARK
+ DEFSV
+ DEFSV_set
+ dITEMS
+ dMY_CXT
+ dMY_CXT_SV
+ dNOOP
+ dTHR
+ dTHX
+ dTHXa
+ dTHXoa
+ dTHXR
+ dUNDERBAR
+ dVAR
+ dXCPT
+ dXSTARG
+ END_EXTERN_C
+ ERRSV
+ eval_pv
+ eval_sv
+ EXTERN_C
+ G_METHOD
+ get_av
+ get_cv
+ get_hv
+ get_sv
+ grok_bin
+ grok_hex
+ grok_number
+ GROK_NUMERIC_RADIX
+ grok_numeric_radix
+ grok_oct
+ gv_fetchpvn_flags
+ gv_fetchpvs
+ gv_stashpvn
+ gv_stashpvs
+ GvSVn
+ hv_fetchs
+ hv_stores
+ HvNAME_get
+ HvNAMELEN_get
+ IN_LOCALE
+ IN_LOCALE_COMPILETIME
+ IN_LOCALE_RUNTIME
+ IN_PERL_COMPILETIME
+ INT2PTR
+ IS_NUMBER_GREATER_THAN_UV_MAX
+ IS_NUMBER_IN_UV
+ IS_NUMBER_INFINITY
+ IS_NUMBER_NAN
+ IS_NUMBER_NEG
+ IS_NUMBER_NOT_INT
+ isALNUMC
+ isASCII
+ isBLANK
+ isCNTRL
+ isGRAPH
+ isGV_with_GP
+ isPRINT
+ isPSXSPC
+ isPUNCT
+ isXDIGIT
+ IVdf
+ IVSIZE
+ IVTYPE
+ load_module
+ memEQ
+ memNE
+ MoveD
+ mPUSHi
+ mPUSHn
+ mPUSHp
+ mPUSHs
+ mPUSHu
+ mXPUSHi
+ mXPUSHn
+ mXPUSHp
+ mXPUSHs
+ mXPUSHu
+ MY_CXT
+ MY_CXT_CLONE
+ MY_CXT_INIT
+ my_snprintf
+ my_sprintf
+ my_strlcat
+ my_strlcpy
+ newCONSTSUB
+ newRV_inc
+ newRV_noinc
+ newSV_type
+ newSVpvn
+ newSVpvn_flags
+ newSVpvn_share
+ newSVpvn_utf8
+ newSVpvs
+ newSVpvs_flags
+ newSVuv
+ Newx
+ Newxc
+ Newxz
+ NOOP
+ NUM2PTR
+ NVef
+ NVff
+ NVgf
+ NVTYPE
+ packWARN
+ PERL_ABS
+ PERL_BCDVERSION
+ PERL_GCC_BRACE_GROUPS_FORBIDDEN
+ PERL_HASH
+ PERL_INT_MAX
+ PERL_INT_MIN
+ PERL_LONG_MAX
+ PERL_LONG_MIN
+ PERL_MAGIC_arylen
+ PERL_MAGIC_backref
+ PERL_MAGIC_bm
+ PERL_MAGIC_collxfrm
+ PERL_MAGIC_dbfile
+ PERL_MAGIC_dbline
+ PERL_MAGIC_defelem
+ PERL_MAGIC_env
+ PERL_MAGIC_envelem
+ PERL_MAGIC_ext
+ PERL_MAGIC_fm
+ PERL_MAGIC_glob
+ PERL_MAGIC_isa
+ PERL_MAGIC_isaelem
+ PERL_MAGIC_mutex
+ PERL_MAGIC_nkeys
+ PERL_MAGIC_overload
+ PERL_MAGIC_overload_elem
+ PERL_MAGIC_overload_table
+ PERL_MAGIC_pos
+ PERL_MAGIC_qr
+ PERL_MAGIC_regdata
+ PERL_MAGIC_regdatum
+ PERL_MAGIC_regex_global
+ PERL_MAGIC_shared
+ PERL_MAGIC_shared_scalar
+ PERL_MAGIC_sig
+ PERL_MAGIC_sigelem
+ PERL_MAGIC_substr
+ PERL_MAGIC_sv
+ PERL_MAGIC_taint
+ PERL_MAGIC_tied
+ PERL_MAGIC_tiedelem
+ PERL_MAGIC_tiedscalar
+ PERL_MAGIC_utf8
+ PERL_MAGIC_uvar
+ PERL_MAGIC_uvar_elem
+ PERL_MAGIC_vec
+ PERL_MAGIC_vstring
+ PERL_PV_ESCAPE_ALL
+ PERL_PV_ESCAPE_FIRSTCHAR
+ PERL_PV_ESCAPE_NOBACKSLASH
+ PERL_PV_ESCAPE_NOCLEAR
+ PERL_PV_ESCAPE_QUOTE
+ PERL_PV_ESCAPE_RE
+ PERL_PV_ESCAPE_UNI
+ PERL_PV_ESCAPE_UNI_DETECT
+ PERL_PV_PRETTY_DUMP
+ PERL_PV_PRETTY_ELLIPSES
+ PERL_PV_PRETTY_LTGT
+ PERL_PV_PRETTY_NOCLEAR
+ PERL_PV_PRETTY_QUOTE
+ PERL_PV_PRETTY_REGPROP
+ PERL_QUAD_MAX
+ PERL_QUAD_MIN
+ PERL_REVISION
+ PERL_SCAN_ALLOW_UNDERSCORES
+ PERL_SCAN_DISALLOW_PREFIX
+ PERL_SCAN_GREATER_THAN_UV_MAX
+ PERL_SCAN_SILENT_ILLDIGIT
+ PERL_SHORT_MAX
+ PERL_SHORT_MIN
+ PERL_SIGNALS_UNSAFE_FLAG
+ PERL_SUBVERSION
+ PERL_UCHAR_MAX
+ PERL_UCHAR_MIN
+ PERL_UINT_MAX
+ PERL_UINT_MIN
+ PERL_ULONG_MAX
+ PERL_ULONG_MIN
+ PERL_UNUSED_ARG
+ PERL_UNUSED_CONTEXT
+ PERL_UNUSED_DECL
+ PERL_UNUSED_VAR
+ PERL_UQUAD_MAX
+ PERL_UQUAD_MIN
+ PERL_USE_GCC_BRACE_GROUPS
+ PERL_USHORT_MAX
+ PERL_USHORT_MIN
+ PERL_VERSION
+ Perl_warner
+ Perl_warner_nocontext
+ PERLIO_FUNCS_CAST
+ PERLIO_FUNCS_DECL
+ PL_bufend
+ PL_bufptr
+ PL_compiling
+ PL_copline
+ PL_curcop
+ PL_curstash
+ PL_DBsignal
+ PL_DBsingle
+ PL_DBsub
+ PL_DBtrace
+ PL_debstash
+ PL_defgv
+ PL_diehook
+ PL_dirty
+ PL_dowarn
+ PL_errgv
+ PL_error_count
+ PL_expect
+ PL_hexdigit
+ PL_hints
+ PL_in_my
+ PL_in_my_stash
+ PL_laststatval
+ PL_lex_state
+ PL_lex_stuff
+ PL_linestr
+ PL_na
+ PL_no_modify
+ PL_parser
+ PL_perl_destruct_level
+ PL_perldb
+ PL_ppaddr
+ PL_rsfp
+ PL_rsfp_filters
+ PL_signals
+ PL_stack_base
+ PL_stack_sp
+ PL_statcache
+ PL_stdingv
+ PL_Sv
+ PL_sv_arenaroot
+ PL_sv_no
+ PL_sv_undef
+ PL_sv_yes
+ PL_tainted
+ PL_tainting
+ PL_tokenbuf
+ pMY_CXT
+ pMY_CXT_
+ Poison
+ PoisonFree
+ PoisonNew
+ PoisonWith
+ pTHX
+ pTHX_
+ PTR2IV
+ PTR2nat
+ PTR2NV
+ PTR2ul
+ PTR2UV
+ PTRV
+ PUSHmortal
+ PUSHu
+ pv_display
+ pv_escape
+ pv_pretty
+ SAVE_DEFSV
+ START_EXTERN_C
+ START_MY_CXT
+ STMT_END
+ STMT_START
+ STR_WITH_LEN
+ sv_2pv_flags
+ sv_2pv_nolen
+ sv_2pvbyte
+ sv_2pvbyte_nolen
+ sv_2uv
+ sv_catpv_mg
+ sv_catpvf_mg
+ sv_catpvf_mg_nocontext
+ sv_catpvn_mg
+ sv_catpvn_nomg
+ sv_catpvs
+ sv_catsv_mg
+ sv_catsv_nomg
+ SV_CONST_RETURN
+ SV_COW_DROP_PV
+ SV_COW_SHARED_HASH_KEYS
+ SV_GMAGIC
+ SV_HAS_TRAILING_NUL
+ SV_IMMEDIATE_UNREF
+ sv_magic_portable
+ SV_MUTABLE_RETURN
+ SV_NOSTEAL
+ sv_pvn_force_flags
+ sv_pvn_nomg
+ sv_setiv_mg
+ sv_setnv_mg
+ sv_setpv_mg
+ sv_setpvf_mg
+ sv_setpvf_mg_nocontext
+ sv_setpvn_mg
+ sv_setpvs
+ sv_setsv_mg
+ sv_setsv_nomg
+ sv_setuv
+ sv_setuv_mg
+ SV_SMAGIC
+ sv_usepvn_mg
+ SV_UTF8_NO_ENCODING
+ sv_uv
+ sv_vcatpvf
+ sv_vcatpvf_mg
+ sv_vsetpvf
+ sv_vsetpvf_mg
+ SVf
+ SVf_UTF8
+ SVfARG
+ SvGETMAGIC
+ SvIV_nomg
+ SvMAGIC_set
+ SvPV_const
+ SvPV_flags
+ SvPV_flags_const
+ SvPV_flags_const_nolen
+ SvPV_flags_mutable
+ SvPV_force
+ SvPV_force_flags
+ SvPV_force_flags_mutable
+ SvPV_force_flags_nolen
+ SvPV_force_mutable
+ SvPV_force_nolen
+ SvPV_force_nomg
+ SvPV_force_nomg_nolen
+ SvPV_mutable
+ SvPV_nolen
+ SvPV_nolen_const
+ SvPV_nomg
+ SvPV_nomg_const
+ SvPV_nomg_const_nolen
+ SvPV_renew
+ SvPVbyte
+ SvPVX_const
+ SvPVX_mutable
+ SvREFCNT_inc
+ SvREFCNT_inc_NN
+ SvREFCNT_inc_simple
+ SvREFCNT_inc_simple_NN
+ SvREFCNT_inc_simple_void
+ SvREFCNT_inc_simple_void_NN
+ SvREFCNT_inc_void
+ SvREFCNT_inc_void_NN
+ SvRV_set
+ SvSHARED_HASH
+ SvSTASH_set
+ SvUOK
+ SvUV
+ SvUV_nomg
+ SvUV_set
+ SvUVX
+ SvUVx
+ SvUVXx
+ SvVSTRING_mg
+ UNDERBAR
+ UTF8_MAXBYTES
+ UVof
+ UVSIZE
+ UVTYPE
+ UVuf
+ UVXf
+ UVxf
+ vload_module
+ vnewSVpvf
+ WARN_ALL
+ WARN_AMBIGUOUS
+ WARN_ASSERTIONS
+ WARN_BAREWORD
+ WARN_CLOSED
+ WARN_CLOSURE
+ WARN_DEBUGGING
+ WARN_DEPRECATED
+ WARN_DIGIT
+ WARN_EXEC
+ WARN_EXITING
+ WARN_GLOB
+ WARN_INPLACE
+ WARN_INTERNAL
+ WARN_IO
+ WARN_LAYER
+ WARN_MALLOC
+ WARN_MISC
+ WARN_NEWLINE
+ WARN_NUMERIC
+ WARN_ONCE
+ WARN_OVERFLOW
+ WARN_PACK
+ WARN_PARENTHESIS
+ WARN_PIPE
+ WARN_PORTABLE
+ WARN_PRECEDENCE
+ WARN_PRINTF
+ WARN_PROTOTYPE
+ WARN_QW
+ WARN_RECURSION
+ WARN_REDEFINE
+ WARN_REGEXP
+ WARN_RESERVED
+ WARN_SEMICOLON
+ WARN_SEVERE
+ WARN_SIGNAL
+ WARN_SUBSTR
+ WARN_SYNTAX
+ WARN_TAINT
+ WARN_THREADS
+ WARN_UNINITIALIZED
+ WARN_UNOPENED
+ WARN_UNPACK
+ WARN_UNTIE
+ WARN_UTF8
+ WARN_VOID
+ warner
+ XCPT_CATCH
+ XCPT_RETHROW
+ XCPT_TRY_END
+ XCPT_TRY_START
+ XPUSHmortal
+ XPUSHu
+ XSprePUSH
+ XSPROTO
+ XSRETURN
+ XSRETURN_UV
+ XST_mUV
+ ZeroD
+
+=head2 Perl API not supported by ppport.h
+
+There is still a big part of the API not supported by F<ppport.h>.
+Either because it doesn't make sense to back-port that part of the API,
+or simply because it hasn't been implemented yet. Patches welcome!
+
+Here's a list of the currently unsupported API, and also the version of
+Perl below which it is unsupported:
+
+=over 4
+
+=item perl 5.11.0
+
+ HeUTF8
+ MULTICALL
+ PERL_SYS_TERM
+ POP_MULTICALL
+ PUSH_MULTICALL
+ SvOOK_offset
+ av_iter_p
+ croak_xs_usage
+ fetch_cop_label
+ gv_fetchmethod_flags
+ hv_assert
+ mro_get_from_name
+ mro_get_private_data
+ mro_register
+ mro_set_mro
+ mro_set_private_data
+ pad_sv
+ pregfree2
+ ref
+ save_adelete
+ save_helem_flags
+ save_padsv_and_mortalize
+ save_pushptr
+ stashpv_hvname_match
+ sv_insert_flags
+ sv_utf8_upgrade_flags_grow
+
+=item perl 5.10.0
+
+ hv_common
+ hv_common_key_len
+ sv_destroyable
+ sys_init
+ sys_init3
+ sys_term
+
+=item perl 5.9.5
+
+ Perl_signbit
+ SvRX
+ SvRXOK
+ av_create_and_push
+ av_create_and_unshift_one
+ get_cvn_flags
+ gv_fetchfile_flags
+ mro_get_linear_isa
+ mro_method_changed_in
+ my_dirfd
+ pregcomp
+ ptr_table_clear
+ ptr_table_fetch
+ ptr_table_free
+ ptr_table_new
+ ptr_table_split
+ ptr_table_store
+ re_compile
+ re_intuit_start
+ reg_named_buff_all
+ reg_named_buff_exists
+ reg_named_buff_fetch
+ reg_named_buff_firstkey
+ reg_named_buff_nextkey
+ reg_named_buff_scalar
+ regfree_internal
+ savesharedpvn
+ scan_vstring
+ upg_version
+
+=item perl 5.9.4
+
+ PerlIO_context_layers
+ gv_name_set
+ my_vsnprintf
+ newXS_flags
+ regclass_swash
+ sv_does
+ sv_usepvn_flags
+
+=item perl 5.9.3
+
+ av_arylen_p
+ ckwarn
+ ckwarn_d
+ csighandler
+ dMULTICALL
+ doref
+ gv_const_sv
+ hv_eiter_p
+ hv_eiter_set
+ hv_name_set
+ hv_placeholders_get
+ hv_placeholders_p
+ hv_placeholders_set
+ hv_riter_p
+ hv_riter_set
+ is_utf8_string_loclen
+ newGIVENOP
+ newSVhek
+ newSVpvs_share
+ newWHENOP
+ newWHILEOP
+ savepvs
+ sortsv_flags
+ vverify
+
+=item perl 5.9.2
+
+ SvPVbyte_force
+ find_rundefsvoffset
+ gv_fetchsv
+ op_refcnt_lock
+ op_refcnt_unlock
+ savesvpv
+ vnormal
+
+=item perl 5.9.1
+
+ hv_clear_placeholders
+ hv_scalar
+ scan_version
+ sv_2iv_flags
+ sv_2uv_flags
+
+=item perl 5.9.0
+
+ new_version
+ save_set_svflags
+ vcmp
+ vnumify
+ vstringify
+
+=item perl 5.8.3
+
+ SvIsCOW
+ SvIsCOW_shared_hash
+
+=item perl 5.8.1
+
+ SvVOK
+ doing_taint
+ find_runcv
+ is_utf8_string_loc
+ packlist
+ save_bool
+ savestack_grow_cnt
+ seed
+ sv_cat_decode
+ sv_compile_2op
+ sv_setpviv
+ sv_setpviv_mg
+ unpackstring
+
+=item perl 5.8.0
+
+ hv_iternext_flags
+ hv_store_flags
+ is_utf8_idcont
+ nothreadhook
+
+=item perl 5.7.3
+
+ PerlIO_clearerr
+ PerlIO_close
+ PerlIO_eof
+ PerlIO_error
+ PerlIO_fileno
+ PerlIO_fill
+ PerlIO_flush
+ PerlIO_get_base
+ PerlIO_get_bufsiz
+ PerlIO_get_cnt
+ PerlIO_get_ptr
+ PerlIO_read
+ PerlIO_seek
+ PerlIO_set_cnt
+ PerlIO_set_ptrcnt
+ PerlIO_setlinebuf
+ PerlIO_stderr
+ PerlIO_stdin
+ PerlIO_stdout
+ PerlIO_tell
+ PerlIO_unread
+ PerlIO_write
+ SvLOCK
+ SvSHARE
+ SvUNLOCK
+ atfork_lock
+ atfork_unlock
+ custom_op_desc
+ custom_op_name
+ deb
+ debstack
+ debstackptrs
+ gv_fetchmeth_autoload
+ ibcmp_utf8
+ my_fork
+ my_socketpair
+ pack_cat
+ perl_destruct
+ pv_uni_display
+ save_shared_pvref
+ savesharedpv
+ sortsv
+ sv_copypv
+ sv_magicext
+ sv_nolocking
+ sv_nosharing
+ sv_recode_to_utf8
+ sv_uni_display
+ to_uni_fold
+ to_uni_lower
+ to_uni_title
+ to_uni_upper
+ to_utf8_case
+ to_utf8_fold
+ to_utf8_lower
+ to_utf8_title
+ to_utf8_upper
+ unpack_str
+ uvchr_to_utf8_flags
+ uvuni_to_utf8_flags
+ vdeb
+
+=item perl 5.7.2
+
+ calloc
+ getcwd_sv
+ init_tm
+ malloc
+ mfree
+ mini_mktime
+ my_atof2
+ my_strftime
+ op_null
+ realloc
+ sv_catpvn_flags
+ sv_catsv_flags
+ sv_setsv_flags
+ sv_utf8_upgrade_flags
+ sv_utf8_upgrade_nomg
+ swash_fetch
+
+=item perl 5.7.1
+
+ POPpbytex
+ bytes_from_utf8
+ despatch_signals
+ do_openn
+ gv_handler
+ is_lvalue_sub
+ my_popen_list
+ save_mortalizesv
+ scan_num
+ sv_force_normal_flags
+ sv_setref_uv
+ sv_unref_flags
+ sv_utf8_upgrade
+ utf8_length
+ utf8_to_uvchr
+ utf8_to_uvuni
+ utf8n_to_uvuni
+ uvuni_to_utf8
+
+=item perl 5.6.1
+
+ SvGAMAGIC
+ apply_attrs_string
+ bytes_to_utf8
+ gv_efullname4
+ gv_fullname4
+ is_utf8_string
+ save_generic_pvref
+ utf16_to_utf8
+ utf16_to_utf8_reversed
+ utf8_to_bytes
+
+=item perl 5.6.0
+
+ PERL_SYS_INIT3
+ SvIOK_UV
+ SvIOK_notUV
+ SvIOK_only_UV
+ SvPOK_only_UTF8
+ SvPVbyte_nolen
+ SvPVbytex
+ SvPVbytex_force
+ SvPVutf8
+ SvPVutf8_force
+ SvPVutf8_nolen
+ SvPVutf8x
+ SvPVutf8x_force
+ SvUOK
+ SvUTF8
+ SvUTF8_off
+ SvUTF8_on
+ av_delete
+ av_exists
+ call_atexit
+ cast_i32
+ cast_iv
+ cast_ulong
+ cast_uv
+ do_gv_dump
+ do_gvgv_dump
+ do_hv_dump
+ do_magic_dump
+ do_op_dump
+ do_open9
+ do_pmop_dump
+ do_sv_dump
+ dump_all
+ dump_eval
+ dump_form
+ dump_indent
+ dump_packsubs
+ dump_sub
+ dump_vindent
+ get_context
+ get_ppaddr
+ gv_dump
+ init_i18nl10n
+ init_i18nl14n
+ is_uni_alnum
+ is_uni_alnum_lc
+ is_uni_alnumc
+ is_uni_alnumc_lc
+ is_uni_alpha
+ is_uni_alpha_lc
+ is_uni_ascii
+ is_uni_ascii_lc
+ is_uni_cntrl
+ is_uni_cntrl_lc
+ is_uni_digit
+ is_uni_digit_lc
+ is_uni_graph
+ is_uni_graph_lc
+ is_uni_idfirst
+ is_uni_idfirst_lc
+ is_uni_lower
+ is_uni_lower_lc
+ is_uni_print
+ is_uni_print_lc
+ is_uni_punct
+ is_uni_punct_lc
+ is_uni_space
+ is_uni_space_lc
+ is_uni_upper
+ is_uni_upper_lc
+ is_uni_xdigit
+ is_uni_xdigit_lc
+ is_utf8_alnum
+ is_utf8_alnumc
+ is_utf8_alpha
+ is_utf8_ascii
+ is_utf8_char
+ is_utf8_cntrl
+ is_utf8_digit
+ is_utf8_graph
+ is_utf8_idfirst
+ is_utf8_lower
+ is_utf8_mark
+ is_utf8_print
+ is_utf8_punct
+ is_utf8_space
+ is_utf8_upper
+ is_utf8_xdigit
+ magic_dump
+ mess
+ my_atof
+ my_fflush_all
+ newANONATTRSUB
+ newATTRSUB
+ newXS
+ newXSproto
+ new_collate
+ new_ctype
+ new_numeric
+ op_dump
+ perl_parse
+ pmop_dump
+ re_intuit_string
+ reginitcolors
+ require_pv
+ safesyscalloc
+ safesysfree
+ safesysmalloc
+ safesysrealloc
+ save_I8
+ save_alloc
+ save_destructor
+ save_destructor_x
+ save_re_context
+ save_vptr
+ scan_bin
+ set_context
+ set_numeric_local
+ set_numeric_radix
+ set_numeric_standard
+ str_to_version
+ sv_2pvutf8
+ sv_2pvutf8_nolen
+ sv_force_normal
+ sv_len_utf8
+ sv_pos_b2u
+ sv_pos_u2b
+ sv_pv
+ sv_pvbyte
+ sv_pvbyten
+ sv_pvbyten_force
+ sv_pvutf8
+ sv_pvutf8n
+ sv_pvutf8n_force
+ sv_rvweaken
+ sv_utf8_decode
+ sv_utf8_downgrade
+ sv_utf8_encode
+ swash_init
+ tmps_grow
+ to_uni_lower_lc
+ to_uni_title_lc
+ to_uni_upper_lc
+ utf8_distance
+ utf8_hop
+ vcroak
+ vform
+ vmess
+ vwarn
+ vwarner
+
+=item perl 5.005_03
+
+ POPpx
+ get_vtbl
+ save_generic_svref
+
+=item perl 5.005
+
+ PL_modglobal
+ cx_dump
+ debop
+ debprofdump
+ fbm_compile
+ fbm_instr
+ get_op_descs
+ get_op_names
+ init_stacks
+ mg_length
+ mg_size
+ newHVhv
+ new_stackinfo
+ regdump
+ regexec_flags
+ regnext
+ runops_debug
+ runops_standard
+ save_iv
+ screaminstr
+ sv_iv
+ sv_nv
+ sv_peek
+ sv_pvn
+ sv_pvn_nomg
+ sv_true
+
+=item perl 5.004_05
+
+ do_binmode
+ save_aelem
+ save_helem
+
+=item perl 5.004
+
+ GIMME_V
+ G_VOID
+ HEf_SVKEY
+ HeHASH
+ HeKEY
+ HeKLEN
+ HePV
+ HeSVKEY
+ HeSVKEY_force
+ HeSVKEY_set
+ HeVAL
+ SvSetMagicSV
+ SvSetMagicSV_nosteal
+ SvSetSV_nosteal
+ SvTAINTED
+ SvTAINTED_off
+ SvTAINTED_on
+ block_gimme
+ call_list
+ cv_const_sv
+ delimcpy
+ do_open
+ form
+ gv_autoload4
+ gv_efullname3
+ gv_fetchmethod_autoload
+ gv_fullname3
+ hv_delayfree_ent
+ hv_delete_ent
+ hv_exists_ent
+ hv_fetch_ent
+ hv_free_ent
+ hv_iterkeysv
+ hv_ksplit
+ hv_store_ent
+ ibcmp_locale
+ my_failure_exit
+ my_memcmp
+ my_pclose
+ my_popen
+ newSVpvf
+ rsignal
+ rsignal_state
+ save_I16
+ save_gp
+ share_hek
+ start_subparse
+ sv_catpvf
+ sv_catpvf_mg
+ sv_cmp_locale
+ sv_derived_from
+ sv_gets
+ sv_magic_portable
+ sv_setpvf
+ sv_setpvf_mg
+ sv_taint
+ sv_tainted
+ sv_untaint
+ sv_vcatpvf
+ sv_vcatpvf_mg
+ sv_vcatpvfn
+ sv_vsetpvf
+ sv_vsetpvf_mg
+ sv_vsetpvfn
+ unsharepvn
+ vnewSVpvf
+ warner
+
+=back
+
+=head1 BUGS
+
+If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
+system or any of its tests fail, please use the CPAN Request Tracker
+at L<http://rt.cpan.org/> to create a ticket for the module.
+
+=head1 AUTHORS
+
+=over 2
+
+=item *
+
+Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
+
+=item *
+
+Version 2.x was ported to the Perl core by Paul Marquess.
+
+=item *
+
+Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
+
+=back
+
+=head1 COPYRIGHT
+
+Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
+
+Version 2.x, Copyright (C) 2001, Paul Marquess.
+
+Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+See L<h2xs>, L<ppport.h>.
+
+=cut
+
+package Devel::PPPort;
+
+use strict;
+use vars qw($VERSION $data);
+
+$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.19 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+
+sub _init_data
+{
+ $data = do { local $/; <DATA> };
+ my $pkg = 'Devel::PPPort';
+ $data =~ s/__PERL_VERSION__/$]/g;
+ $data =~ s/__VERSION__/$VERSION/g;
+ $data =~ s/__PKG__/$pkg/g;
+ $data =~ s/^\|>//gm;
+}
+
+sub WriteFile
+{
+ my $file = shift || 'ppport.h';
+ defined $data or _init_data();
+ my $copy = $data;
+ $copy =~ s/\bppport\.h\b/$file/g;
+
+ open F, ">$file" or return undef;
+ print F $copy;
+ close F;
+
+ return 1;
+}
+
+1;
+
+__DATA__
+#if 0
+<<'SKIP';
+#endif
+/*
+----------------------------------------------------------------------
+
+ ppport.h -- Perl/Pollution/Portability Version __VERSION__
+
+ Automatically created by __PKG__ running under perl __PERL_VERSION__.
+
+ Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
+ includes in parts/inc/ instead.
+
+ Use 'perldoc ppport.h' to view the documentation below.
+
+----------------------------------------------------------------------
+
+SKIP
+
+|>=pod
+|>
+|>=head1 NAME
+|>
+|>ppport.h - Perl/Pollution/Portability version __VERSION__
+|>
+|>=head1 SYNOPSIS
+|>
+|> perl ppport.h [options] [source files]
+|>
+|> Searches current directory for files if no [source files] are given
+|>
+|> --help show short help
+|>
+|> --version show version
+|>
+|> --patch=file write one patch file with changes
+|> --copy=suffix write changed copies with suffix
+|> --diff=program use diff program and options
+|>
+|> --compat-version=version provide compatibility with Perl version
+|> --cplusplus accept C++ comments
+|>
+|> --quiet don't output anything except fatal errors
+|> --nodiag don't show diagnostics
+|> --nohints don't show hints
+|> --nochanges don't suggest changes
+|> --nofilter don't filter input files
+|>
+|> --strip strip all script and doc functionality from
+|> ppport.h
+|>
+|> --list-provided list provided API
+|> --list-unsupported list unsupported API
+|> --api-info=name show Perl API portability information
+|>
+|>=head1 COMPATIBILITY
+|>
+|>This version of F<ppport.h> is designed to support operation with Perl
+|>installations back to 5.003, and has been tested up to 5.10.0.
+|>
+|>=head1 OPTIONS
+|>
+|>=head2 --help
+|>
+|>Display a brief usage summary.
+|>
+|>=head2 --version
+|>
+|>Display the version of F<ppport.h>.
+|>
+|>=head2 --patch=I<file>
+|>
+|>If this option is given, a single patch file will be created if
+|>any changes are suggested. This requires a working diff program
+|>to be installed on your system.
+|>
+|>=head2 --copy=I<suffix>
+|>
+|>If this option is given, a copy of each file will be saved with
+|>the given suffix that contains the suggested changes. This does
+|>not require any external programs. Note that this does not
+|>automagially add a dot between the original filename and the
+|>suffix. If you want the dot, you have to include it in the option
+|>argument.
+|>
+|>If neither C<--patch> or C<--copy> are given, the default is to
+|>simply print the diffs for each file. This requires either
+|>C<Text::Diff> or a C<diff> program to be installed.
+|>
+|>=head2 --diff=I<program>
+|>
+|>Manually set the diff program and options to use. The default
+|>is to use C<Text::Diff>, when installed, and output unified
+|>context diffs.
+|>
+|>=head2 --compat-version=I<version>
+|>
+|>Tell F<ppport.h> to check for compatibility with the given
+|>Perl version. The default is to check for compatibility with Perl
+|>version 5.003. You can use this option to reduce the output
+|>of F<ppport.h> if you intend to be backward compatible only
+|>down to a certain Perl version.
+|>
+|>=head2 --cplusplus
+|>
+|>Usually, F<ppport.h> will detect C++ style comments and
+|>replace them with C style comments for portability reasons.
+|>Using this option instructs F<ppport.h> to leave C++
+|>comments untouched.
+|>
+|>=head2 --quiet
+|>
+|>Be quiet. Don't print anything except fatal errors.
+|>
+|>=head2 --nodiag
+|>
+|>Don't output any diagnostic messages. Only portability
+|>alerts will be printed.
+|>
+|>=head2 --nohints
+|>
+|>Don't output any hints. Hints often contain useful portability
+|>notes. Warnings will still be displayed.
+|>
+|>=head2 --nochanges
+|>
+|>Don't suggest any changes. Only give diagnostic output and hints
+|>unless these are also deactivated.
+|>
+|>=head2 --nofilter
+|>
+|>Don't filter the list of input files. By default, files not looking
+|>like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
+|>
+|>=head2 --strip
+|>
+|>Strip all script and documentation functionality from F<ppport.h>.
+|>This reduces the size of F<ppport.h> dramatically and may be useful
+|>if you want to include F<ppport.h> in smaller modules without
+|>increasing their distribution size too much.
+|>
+|>The stripped F<ppport.h> will have a C<--unstrip> option that allows
+|>you to undo the stripping, but only if an appropriate C<Devel::PPPort>
+|>module is installed.
+|>
+|>=head2 --list-provided
+|>
+|>Lists the API elements for which compatibility is provided by
+|>F<ppport.h>. Also lists if it must be explicitly requested,
+|>if it has dependencies, and if there are hints or warnings for it.
+|>
+|>=head2 --list-unsupported
+|>
+|>Lists the API elements that are known not to be supported by
+|>F<ppport.h> and below which version of Perl they probably
+|>won't be available or work.
+|>
+|>=head2 --api-info=I<name>
+|>
+|>Show portability information for API elements matching I<name>.
+|>If I<name> is surrounded by slashes, it is interpreted as a regular
+|>expression.
+|>
+|>=head1 DESCRIPTION
+|>
+|>In order for a Perl extension (XS) module to be as portable as possible
+|>across differing versions of Perl itself, certain steps need to be taken.
+|>
+|>=over 4
+|>
+|>=item *
+|>
+|>Including this header is the first major one. This alone will give you
+|>access to a large part of the Perl API that hasn't been available in
+|>earlier Perl releases. Use
+|>
+|> perl ppport.h --list-provided
+|>
+|>to see which API elements are provided by ppport.h.
+|>
+|>=item *
+|>
+|>You should avoid using deprecated parts of the API. For example, using
+|>global Perl variables without the C<PL_> prefix is deprecated. Also,
+|>some API functions used to have a C<perl_> prefix. Using this form is
+|>also deprecated. You can safely use the supported API, as F<ppport.h>
+|>will provide wrappers for older Perl versions.
+|>
+|>=item *
+|>
+|>If you use one of a few functions or variables that were not present in
+|>earlier versions of Perl, and that can't be provided using a macro, you
+|>have to explicitly request support for these functions by adding one or
+|>more C<#define>s in your source code before the inclusion of F<ppport.h>.
+|>
+|>These functions or variables will be marked C<explicit> in the list shown
+|>by C<--list-provided>.
+|>
+|>Depending on whether you module has a single or multiple files that
+|>use such functions or variables, you want either C<static> or global
+|>variants.
+|>
+|>For a C<static> function or variable (used only in a single source
+|>file), use:
+|>
+|> #define NEED_function
+|> #define NEED_variable
+|>
+|>For a global function or variable (used in multiple source files),
+|>use:
+|>
+|> #define NEED_function_GLOBAL
+|> #define NEED_variable_GLOBAL
+|>
+|>Note that you mustn't have more than one global request for the
+|>same function or variable in your project.
+|>
+|> Function / Variable Static Request Global Request
+|> -----------------------------------------------------------------------------------------
+|> PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL
+|> PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
+|> eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
+|> grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
+|> grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
+|> grok_number() NEED_grok_number NEED_grok_number_GLOBAL
+|> grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
+|> grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
+|> load_module() NEED_load_module NEED_load_module_GLOBAL
+|> my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
+|> my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
+|> my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
+|> my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
+|> newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+|> newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
+|> newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
+|> newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
+|> newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
+|> pv_display() NEED_pv_display NEED_pv_display_GLOBAL
+|> pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL
+|> pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL
+|> sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL
+|> sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
+|> sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
+|> sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
+|> sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL
+|> sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
+|> sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
+|> vload_module() NEED_vload_module NEED_vload_module_GLOBAL
+|> vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
+|> warner() NEED_warner NEED_warner_GLOBAL
+|>
+|>To avoid namespace conflicts, you can change the namespace of the
+|>explicitly exported functions / variables using the C<DPPP_NAMESPACE>
+|>macro. Just C<#define> the macro before including C<ppport.h>:
+|>
+|> #define DPPP_NAMESPACE MyOwnNamespace_
+|> #include "ppport.h"
+|>
+|>The default namespace is C<DPPP_>.
+|>
+|>=back
+|>
+|>The good thing is that most of the above can be checked by running
+|>F<ppport.h> on your source code. See the next section for
+|>details.
+|>
+|>=head1 EXAMPLES
+|>
+|>To verify whether F<ppport.h> is needed for your module, whether you
+|>should make any changes to your code, and whether any special defines
+|>should be used, F<ppport.h> can be run as a Perl script to check your
+|>source code. Simply say:
+|>
+|> perl ppport.h
+|>
+|>The result will usually be a list of patches suggesting changes
+|>that should at least be acceptable, if not necessarily the most
+|>efficient solution, or a fix for all possible problems.
+|>
+|>If you know that your XS module uses features only available in
+|>newer Perl releases, if you're aware that it uses C++ comments,
+|>and if you want all suggestions as a single patch file, you could
+|>use something like this:
+|>
+|> perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
+|>
+|>If you only want your code to be scanned without any suggestions
+|>for changes, use:
+|>
+|> perl ppport.h --nochanges
+|>
+|>You can specify a different C<diff> program or options, using
+|>the C<--diff> option:
+|>
+|> perl ppport.h --diff='diff -C 10'
+|>
+|>This would output context diffs with 10 lines of context.
+|>
+|>If you want to create patched copies of your files instead, use:
+|>
+|> perl ppport.h --copy=.new
+|>
+|>To display portability information for the C<newSVpvn> function,
+|>use:
+|>
+|> perl ppport.h --api-info=newSVpvn
+|>
+|>Since the argument to C<--api-info> can be a regular expression,
+|>you can use
+|>
+|> perl ppport.h --api-info=/_nomg$/
+|>
+|>to display portability information for all C<_nomg> functions or
+|>
+|> perl ppport.h --api-info=/./
+|>
+|>to display information for all known API elements.
+|>
+|>=head1 BUGS
+|>
+|>If this version of F<ppport.h> is causing failure during
+|>the compilation of this module, please check if newer versions
+|>of either this module or C<Devel::PPPort> are available on CPAN
+|>before sending a bug report.
+|>
+|>If F<ppport.h> was generated using the latest version of
+|>C<Devel::PPPort> and is causing failure of this module, please
+|>file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
+|>
+|>Please include the following information:
+|>
+|>=over 4
+|>
+|>=item 1.
+|>
+|>The complete output from running "perl -V"
+|>
+|>=item 2.
+|>
+|>This file.
+|>
+|>=item 3.
+|>
+|>The name and version of the module you were trying to build.
+|>
+|>=item 4.
+|>
+|>A full log of the build that failed.
+|>
+|>=item 5.
+|>
+|>Any other information that you think could be relevant.
+|>
+|>=back
+|>
+|>For the latest version of this code, please get the C<Devel::PPPort>
+|>module from CPAN.
+|>
+|>=head1 COPYRIGHT
+|>
+|>Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz.
+|>
+|>Version 2.x, Copyright (C) 2001, Paul Marquess.
+|>
+|>Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+|>
+|>This program is free software; you can redistribute it and/or
+|>modify it under the same terms as Perl itself.
+|>
+|>=head1 SEE ALSO
+|>
+|>See L<Devel::PPPort>.
+|>
+|>=cut
+
+use strict;
+
+# Disable broken TRIE-optimization
+BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
+
+my $VERSION = __VERSION__;
+
+my %opt = (
+ quiet => 0,
+ diag => 1,
+ hints => 1,
+ changes => 1,
+ cplusplus => 0,
+ filter => 1,
+ strip => 0,
+ version => 0,
+);
+
+my($ppport) = $0 =~ /([\w.]+)$/;
+my $LF = '(?:\r\n|[\r\n])'; # line feed
+my $HS = "[ \t]"; # horizontal whitespace
+
+# Never use C comments in this file!
+my $ccs = '/'.'*';
+my $cce = '*'.'/';
+my $rccs = quotemeta $ccs;
+my $rcce = quotemeta $cce;
+
+eval {
+ require Getopt::Long;
+ Getopt::Long::GetOptions(\%opt, qw(
+ help quiet diag! filter! hints! changes! cplusplus strip version
+ patch=s copy=s diff=s compat-version=s
+ list-provided list-unsupported api-info=s
+ )) or usage();
+};
+
+if ($@ and grep /^-/, @ARGV) {
+ usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
+ die "Getopt::Long not found. Please don't use any options.\n";
+}
+
+if ($opt{version}) {
+ print "This is $0 $VERSION.\n";
+ exit 0;
+}
+
+usage() if $opt{help};
+strip() if $opt{strip};
+
+if (exists $opt{'compat-version'}) {
+ my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
+ if ($@) {
+ die "Invalid version number format: '$opt{'compat-version'}'\n";
+ }
+ die "Only Perl 5 is supported\n" if $r != 5;
+ die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
+ $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
+}
+else {
+ $opt{'compat-version'} = 5;
+}
+
+my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
+ ? ( $1 => {
+ ($2 ? ( base => $2 ) : ()),
+ ($3 ? ( todo => $3 ) : ()),
+ (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
+ (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
+ (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
+ } )
+ : die "invalid spec: $_" } qw(
+AvFILLp|5.004050||p
+AvFILL|||
+CLASS|||n
+CPERLscope|5.005000||p
+CX_CURPAD_SAVE|||
+CX_CURPAD_SV|||
+CopFILEAV|5.006000||p
+CopFILEGV_set|5.006000||p
+CopFILEGV|5.006000||p
+CopFILESV|5.006000||p
+CopFILE_set|5.006000||p
+CopFILE|5.006000||p
+CopSTASHPV_set|5.006000||p
+CopSTASHPV|5.006000||p
+CopSTASH_eq|5.006000||p
+CopSTASH_set|5.006000||p
+CopSTASH|5.006000||p
+CopyD|5.009002||p
+Copy|||
+CvPADLIST|||
+CvSTASH|||
+CvWEAKOUTSIDE|||
+DEFSV_set|5.011000||p
+DEFSV|5.004050||p
+END_EXTERN_C|5.005000||p
+ENTER|||
+ERRSV|5.004050||p
+EXTEND|||
+EXTERN_C|5.005000||p
+F0convert|||n
+FREETMPS|||
+GIMME_V||5.004000|n
+GIMME|||n
+GROK_NUMERIC_RADIX|5.007002||p
+G_ARRAY|||
+G_DISCARD|||
+G_EVAL|||
+G_METHOD|5.006001||p
+G_NOARGS|||
+G_SCALAR|||
+G_VOID||5.004000|
+GetVars|||
+GvSVn|5.009003||p
+GvSV|||
+Gv_AMupdate|||
+HEf_SVKEY||5.004000|
+HeHASH||5.004000|
+HeKEY||5.004000|
+HeKLEN||5.004000|
+HePV||5.004000|
+HeSVKEY_force||5.004000|
+HeSVKEY_set||5.004000|
+HeSVKEY||5.004000|
+HeUTF8||5.011000|
+HeVAL||5.004000|
+HvNAMELEN_get|5.009003||p
+HvNAME_get|5.009003||p
+HvNAME|||
+INT2PTR|5.006000||p
+IN_LOCALE_COMPILETIME|5.007002||p
+IN_LOCALE_RUNTIME|5.007002||p
+IN_LOCALE|5.007002||p
+IN_PERL_COMPILETIME|5.008001||p
+IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
+IS_NUMBER_INFINITY|5.007002||p
+IS_NUMBER_IN_UV|5.007002||p
+IS_NUMBER_NAN|5.007003||p
+IS_NUMBER_NEG|5.007002||p
+IS_NUMBER_NOT_INT|5.007002||p
+IVSIZE|5.006000||p
+IVTYPE|5.006000||p
+IVdf|5.006000||p
+LEAVE|||
+LVRET|||
+MARK|||
+MULTICALL||5.011000|
+MY_CXT_CLONE|5.009002||p
+MY_CXT_INIT|5.007003||p
+MY_CXT|5.007003||p
+MoveD|5.009002||p
+Move|||
+NOOP|5.005000||p
+NUM2PTR|5.006000||p
+NVTYPE|5.006000||p
+NVef|5.006001||p
+NVff|5.006001||p
+NVgf|5.006001||p
+Newxc|5.009003||p
+Newxz|5.009003||p
+Newx|5.009003||p
+Nullav|||
+Nullch|||
+Nullcv|||
+Nullhv|||
+Nullsv|||
+ORIGMARK|||
+PAD_BASE_SV|||
+PAD_CLONE_VARS|||
+PAD_COMPNAME_FLAGS|||
+PAD_COMPNAME_GEN_set|||
+PAD_COMPNAME_GEN|||
+PAD_COMPNAME_OURSTASH|||
+PAD_COMPNAME_PV|||
+PAD_COMPNAME_TYPE|||
+PAD_DUP|||
+PAD_RESTORE_LOCAL|||
+PAD_SAVE_LOCAL|||
+PAD_SAVE_SETNULLPAD|||
+PAD_SETSV|||
+PAD_SET_CUR_NOSAVE|||
+PAD_SET_CUR|||
+PAD_SVl|||
+PAD_SV|||
+PERLIO_FUNCS_CAST|5.009003||p
+PERLIO_FUNCS_DECL|5.009003||p
+PERL_ABS|5.008001||p
+PERL_BCDVERSION|5.011000||p
+PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
+PERL_HASH|5.004000||p
+PERL_INT_MAX|5.004000||p
+PERL_INT_MIN|5.004000||p
+PERL_LONG_MAX|5.004000||p
+PERL_LONG_MIN|5.004000||p
+PERL_MAGIC_arylen|5.007002||p
+PERL_MAGIC_backref|5.007002||p
+PERL_MAGIC_bm|5.007002||p
+PERL_MAGIC_collxfrm|5.007002||p
+PERL_MAGIC_dbfile|5.007002||p
+PERL_MAGIC_dbline|5.007002||p
+PERL_MAGIC_defelem|5.007002||p
+PERL_MAGIC_envelem|5.007002||p
+PERL_MAGIC_env|5.007002||p
+PERL_MAGIC_ext|5.007002||p
+PERL_MAGIC_fm|5.007002||p
+PERL_MAGIC_glob|5.011000||p
+PERL_MAGIC_isaelem|5.007002||p
+PERL_MAGIC_isa|5.007002||p
+PERL_MAGIC_mutex|5.011000||p
+PERL_MAGIC_nkeys|5.007002||p
+PERL_MAGIC_overload_elem|5.007002||p
+PERL_MAGIC_overload_table|5.007002||p
+PERL_MAGIC_overload|5.007002||p
+PERL_MAGIC_pos|5.007002||p
+PERL_MAGIC_qr|5.007002||p
+PERL_MAGIC_regdata|5.007002||p
+PERL_MAGIC_regdatum|5.007002||p
+PERL_MAGIC_regex_global|5.007002||p
+PERL_MAGIC_shared_scalar|5.007003||p
+PERL_MAGIC_shared|5.007003||p
+PERL_MAGIC_sigelem|5.007002||p
+PERL_MAGIC_sig|5.007002||p
+PERL_MAGIC_substr|5.007002||p
+PERL_MAGIC_sv|5.007002||p
+PERL_MAGIC_taint|5.007002||p
+PERL_MAGIC_tiedelem|5.007002||p
+PERL_MAGIC_tiedscalar|5.007002||p
+PERL_MAGIC_tied|5.007002||p
+PERL_MAGIC_utf8|5.008001||p
+PERL_MAGIC_uvar_elem|5.007003||p
+PERL_MAGIC_uvar|5.007002||p
+PERL_MAGIC_vec|5.007002||p
+PERL_MAGIC_vstring|5.008001||p
+PERL_PV_ESCAPE_ALL|5.009004||p
+PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p
+PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p
+PERL_PV_ESCAPE_NOCLEAR|5.009004||p
+PERL_PV_ESCAPE_QUOTE|5.009004||p
+PERL_PV_ESCAPE_RE|5.009005||p
+PERL_PV_ESCAPE_UNI_DETECT|5.009004||p
+PERL_PV_ESCAPE_UNI|5.009004||p
+PERL_PV_PRETTY_DUMP|5.009004||p
+PERL_PV_PRETTY_ELLIPSES|5.010000||p
+PERL_PV_PRETTY_LTGT|5.009004||p
+PERL_PV_PRETTY_NOCLEAR|5.010000||p
+PERL_PV_PRETTY_QUOTE|5.009004||p
+PERL_PV_PRETTY_REGPROP|5.009004||p
+PERL_QUAD_MAX|5.004000||p
+PERL_QUAD_MIN|5.004000||p
+PERL_REVISION|5.006000||p
+PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
+PERL_SCAN_DISALLOW_PREFIX|5.007003||p
+PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
+PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
+PERL_SHORT_MAX|5.004000||p
+PERL_SHORT_MIN|5.004000||p
+PERL_SIGNALS_UNSAFE_FLAG|5.008001||p
+PERL_SUBVERSION|5.006000||p
+PERL_SYS_INIT3||5.006000|
+PERL_SYS_INIT|||
+PERL_SYS_TERM||5.011000|
+PERL_UCHAR_MAX|5.004000||p
+PERL_UCHAR_MIN|5.004000||p
+PERL_UINT_MAX|5.004000||p
+PERL_UINT_MIN|5.004000||p
+PERL_ULONG_MAX|5.004000||p
+PERL_ULONG_MIN|5.004000||p
+PERL_UNUSED_ARG|5.009003||p
+PERL_UNUSED_CONTEXT|5.009004||p
+PERL_UNUSED_DECL|5.007002||p
+PERL_UNUSED_VAR|5.007002||p
+PERL_UQUAD_MAX|5.004000||p
+PERL_UQUAD_MIN|5.004000||p
+PERL_USE_GCC_BRACE_GROUPS|5.009004||p
+PERL_USHORT_MAX|5.004000||p
+PERL_USHORT_MIN|5.004000||p
+PERL_VERSION|5.006000||p
+PL_DBsignal|5.005000||p
+PL_DBsingle|||pn
+PL_DBsub|||pn
+PL_DBtrace|||pn
+PL_Sv|5.005000||p
+PL_bufend|5.011000||p
+PL_bufptr|5.011000||p
+PL_compiling|5.004050||p
+PL_copline|5.011000||p
+PL_curcop|5.004050||p
+PL_curstash|5.004050||p
+PL_debstash|5.004050||p
+PL_defgv|5.004050||p
+PL_diehook|5.004050||p
+PL_dirty|5.004050||p
+PL_dowarn|||pn
+PL_errgv|5.004050||p
+PL_error_count|5.011000||p
+PL_expect|5.011000||p
+PL_hexdigit|5.005000||p
+PL_hints|5.005000||p
+PL_in_my_stash|5.011000||p
+PL_in_my|5.011000||p
+PL_last_in_gv|||n
+PL_laststatval|5.005000||p
+PL_lex_state|5.011000||p
+PL_lex_stuff|5.011000||p
+PL_linestr|5.011000||p
+PL_modglobal||5.005000|n
+PL_na|5.004050||pn
+PL_no_modify|5.006000||p
+PL_ofsgv|||n
+PL_parser|5.009005||p
+PL_perl_destruct_level|5.004050||p
+PL_perldb|5.004050||p
+PL_ppaddr|5.006000||p
+PL_rsfp_filters|5.004050||p
+PL_rsfp|5.004050||p
+PL_rs|||n
+PL_signals|5.008001||p
+PL_stack_base|5.004050||p
+PL_stack_sp|5.004050||p
+PL_statcache|5.005000||p
+PL_stdingv|5.004050||p
+PL_sv_arenaroot|5.004050||p
+PL_sv_no|5.004050||pn
+PL_sv_undef|5.004050||pn
+PL_sv_yes|5.004050||pn
+PL_tainted|5.004050||p
+PL_tainting|5.004050||p
+PL_tokenbuf|5.011000||p
+POP_MULTICALL||5.011000|
+POPi|||n
+POPl|||n
+POPn|||n
+POPpbytex||5.007001|n
+POPpx||5.005030|n
+POPp|||n
+POPs|||n
+PTR2IV|5.006000||p
+PTR2NV|5.006000||p
+PTR2UV|5.006000||p
+PTR2nat|5.009003||p
+PTR2ul|5.007001||p
+PTRV|5.006000||p
+PUSHMARK|||
+PUSH_MULTICALL||5.011000|
+PUSHi|||
+PUSHmortal|5.009002||p
+PUSHn|||
+PUSHp|||
+PUSHs|||
+PUSHu|5.004000||p
+PUTBACK|||
+PerlIO_clearerr||5.007003|
+PerlIO_close||5.007003|
+PerlIO_context_layers||5.009004|
+PerlIO_eof||5.007003|
+PerlIO_error||5.007003|
+PerlIO_fileno||5.007003|
+PerlIO_fill||5.007003|
+PerlIO_flush||5.007003|
+PerlIO_get_base||5.007003|
+PerlIO_get_bufsiz||5.007003|
+PerlIO_get_cnt||5.007003|
+PerlIO_get_ptr||5.007003|
+PerlIO_read||5.007003|
+PerlIO_seek||5.007003|
+PerlIO_set_cnt||5.007003|
+PerlIO_set_ptrcnt||5.007003|
+PerlIO_setlinebuf||5.007003|
+PerlIO_stderr||5.007003|
+PerlIO_stdin||5.007003|
+PerlIO_stdout||5.007003|
+PerlIO_tell||5.007003|
+PerlIO_unread||5.007003|
+PerlIO_write||5.007003|
+Perl_signbit||5.009005|n
+PoisonFree|5.009004||p
+PoisonNew|5.009004||p
+PoisonWith|5.009004||p
+Poison|5.008000||p
+RETVAL|||n
+Renewc|||
+Renew|||
+SAVECLEARSV|||
+SAVECOMPPAD|||
+SAVEPADSV|||
+SAVETMPS|||
+SAVE_DEFSV|5.004050||p
+SPAGAIN|||
+SP|||
+START_EXTERN_C|5.005000||p
+START_MY_CXT|5.007003||p
+STMT_END|||p
+STMT_START|||p
+STR_WITH_LEN|5.009003||p
+ST|||
+SV_CONST_RETURN|5.009003||p
+SV_COW_DROP_PV|5.008001||p
+SV_COW_SHARED_HASH_KEYS|5.009005||p
+SV_GMAGIC|5.007002||p
+SV_HAS_TRAILING_NUL|5.009004||p
+SV_IMMEDIATE_UNREF|5.007001||p
+SV_MUTABLE_RETURN|5.009003||p
+SV_NOSTEAL|5.009002||p
+SV_SMAGIC|5.009003||p
+SV_UTF8_NO_ENCODING|5.008001||p
+SVfARG|5.009005||p
+SVf_UTF8|5.006000||p
+SVf|5.006000||p
+SVt_IV|||
+SVt_NV|||
+SVt_PVAV|||
+SVt_PVCV|||
+SVt_PVHV|||
+SVt_PVMG|||
+SVt_PV|||
+Safefree|||
+Slab_Alloc|||
+Slab_Free|||
+Slab_to_rw|||
+StructCopy|||
+SvCUR_set|||
+SvCUR|||
+SvEND|||
+SvGAMAGIC||5.006001|
+SvGETMAGIC|5.004050||p
+SvGROW|||
+SvIOK_UV||5.006000|
+SvIOK_notUV||5.006000|
+SvIOK_off|||
+SvIOK_only_UV||5.006000|
+SvIOK_only|||
+SvIOK_on|||
+SvIOKp|||
+SvIOK|||
+SvIVX|||
+SvIV_nomg|5.009001||p
+SvIV_set|||
+SvIVx|||
+SvIV|||
+SvIsCOW_shared_hash||5.008003|
+SvIsCOW||5.008003|
+SvLEN_set|||
+SvLEN|||
+SvLOCK||5.007003|
+SvMAGIC_set|5.009003||p
+SvNIOK_off|||
+SvNIOKp|||
+SvNIOK|||
+SvNOK_off|||
+SvNOK_only|||
+SvNOK_on|||
+SvNOKp|||
+SvNOK|||
+SvNVX|||
+SvNV_set|||
+SvNVx|||
+SvNV|||
+SvOK|||
+SvOOK_offset||5.011000|
+SvOOK|||
+SvPOK_off|||
+SvPOK_only_UTF8||5.006000|
+SvPOK_only|||
+SvPOK_on|||
+SvPOKp|||
+SvPOK|||
+SvPVX_const|5.009003||p
+SvPVX_mutable|5.009003||p
+SvPVX|||
+SvPV_const|5.009003||p
+SvPV_flags_const_nolen|5.009003||p
+SvPV_flags_const|5.009003||p
+SvPV_flags_mutable|5.009003||p
+SvPV_flags|5.007002||p
+SvPV_force_flags_mutable|5.009003||p
+SvPV_force_flags_nolen|5.009003||p
+SvPV_force_flags|5.007002||p
+SvPV_force_mutable|5.009003||p
+SvPV_force_nolen|5.009003||p
+SvPV_force_nomg_nolen|5.009003||p
+SvPV_force_nomg|5.007002||p
+SvPV_force|||p
+SvPV_mutable|5.009003||p
+SvPV_nolen_const|5.009003||p
+SvPV_nolen|5.006000||p
+SvPV_nomg_const_nolen|5.009003||p
+SvPV_nomg_const|5.009003||p
+SvPV_nomg|5.007002||p
+SvPV_renew|5.009003||p
+SvPV_set|||
+SvPVbyte_force||5.009002|
+SvPVbyte_nolen||5.006000|
+SvPVbytex_force||5.006000|
+SvPVbytex||5.006000|
+SvPVbyte|5.006000||p
+SvPVutf8_force||5.006000|
+SvPVutf8_nolen||5.006000|
+SvPVutf8x_force||5.006000|
+SvPVutf8x||5.006000|
+SvPVutf8||5.006000|
+SvPVx|||
+SvPV|||
+SvREFCNT_dec|||
+SvREFCNT_inc_NN|5.009004||p
+SvREFCNT_inc_simple_NN|5.009004||p
+SvREFCNT_inc_simple_void_NN|5.009004||p
+SvREFCNT_inc_simple_void|5.009004||p
+SvREFCNT_inc_simple|5.009004||p
+SvREFCNT_inc_void_NN|5.009004||p
+SvREFCNT_inc_void|5.009004||p
+SvREFCNT_inc|||p
+SvREFCNT|||
+SvROK_off|||
+SvROK_on|||
+SvROK|||
+SvRV_set|5.009003||p
+SvRV|||
+SvRXOK||5.009005|
+SvRX||5.009005|
+SvSETMAGIC|||
+SvSHARED_HASH|5.009003||p
+SvSHARE||5.007003|
+SvSTASH_set|5.009003||p
+SvSTASH|||
+SvSetMagicSV_nosteal||5.004000|
+SvSetMagicSV||5.004000|
+SvSetSV_nosteal||5.004000|
+SvSetSV|||
+SvTAINTED_off||5.004000|
+SvTAINTED_on||5.004000|
+SvTAINTED||5.004000|
+SvTAINT|||
+SvTRUE|||
+SvTYPE|||
+SvUNLOCK||5.007003|
+SvUOK|5.007001|5.006000|p
+SvUPGRADE|||
+SvUTF8_off||5.006000|
+SvUTF8_on||5.006000|
+SvUTF8||5.006000|
+SvUVXx|5.004000||p
+SvUVX|5.004000||p
+SvUV_nomg|5.009001||p
+SvUV_set|5.009003||p
+SvUVx|5.004000||p
+SvUV|5.004000||p
+SvVOK||5.008001|
+SvVSTRING_mg|5.009004||p
+THIS|||n
+UNDERBAR|5.009002||p
+UTF8_MAXBYTES|5.009002||p
+UVSIZE|5.006000||p
+UVTYPE|5.006000||p
+UVXf|5.007001||p
+UVof|5.006000||p
+UVuf|5.006000||p
+UVxf|5.006000||p
+WARN_ALL|5.006000||p
+WARN_AMBIGUOUS|5.006000||p
+WARN_ASSERTIONS|5.011000||p
+WARN_BAREWORD|5.006000||p
+WARN_CLOSED|5.006000||p
+WARN_CLOSURE|5.006000||p
+WARN_DEBUGGING|5.006000||p
+WARN_DEPRECATED|5.006000||p
+WARN_DIGIT|5.006000||p
+WARN_EXEC|5.006000||p
+WARN_EXITING|5.006000||p
+WARN_GLOB|5.006000||p
+WARN_INPLACE|5.006000||p
+WARN_INTERNAL|5.006000||p
+WARN_IO|5.006000||p
+WARN_LAYER|5.008000||p
+WARN_MALLOC|5.006000||p
+WARN_MISC|5.006000||p
+WARN_NEWLINE|5.006000||p
+WARN_NUMERIC|5.006000||p
+WARN_ONCE|5.006000||p
+WARN_OVERFLOW|5.006000||p
+WARN_PACK|5.006000||p
+WARN_PARENTHESIS|5.006000||p
+WARN_PIPE|5.006000||p
+WARN_PORTABLE|5.006000||p
+WARN_PRECEDENCE|5.006000||p
+WARN_PRINTF|5.006000||p
+WARN_PROTOTYPE|5.006000||p
+WARN_QW|5.006000||p
+WARN_RECURSION|5.006000||p
+WARN_REDEFINE|5.006000||p
+WARN_REGEXP|5.006000||p
+WARN_RESERVED|5.006000||p
+WARN_SEMICOLON|5.006000||p
+WARN_SEVERE|5.006000||p
+WARN_SIGNAL|5.006000||p
+WARN_SUBSTR|5.006000||p
+WARN_SYNTAX|5.006000||p
+WARN_TAINT|5.006000||p
+WARN_THREADS|5.008000||p
+WARN_UNINITIALIZED|5.006000||p
+WARN_UNOPENED|5.006000||p
+WARN_UNPACK|5.006000||p
+WARN_UNTIE|5.006000||p
+WARN_UTF8|5.006000||p
+WARN_VOID|5.006000||p
+XCPT_CATCH|5.009002||p
+XCPT_RETHROW|5.009002||p
+XCPT_TRY_END|5.009002||p
+XCPT_TRY_START|5.009002||p
+XPUSHi|||
+XPUSHmortal|5.009002||p
+XPUSHn|||
+XPUSHp|||
+XPUSHs|||
+XPUSHu|5.004000||p
+XSPROTO|5.010000||p
+XSRETURN_EMPTY|||
+XSRETURN_IV|||
+XSRETURN_NO|||
+XSRETURN_NV|||
+XSRETURN_PV|||
+XSRETURN_UNDEF|||
+XSRETURN_UV|5.008001||p
+XSRETURN_YES|||
+XSRETURN|||p
+XST_mIV|||
+XST_mNO|||
+XST_mNV|||
+XST_mPV|||
+XST_mUNDEF|||
+XST_mUV|5.008001||p
+XST_mYES|||
+XS_VERSION_BOOTCHECK|||
+XS_VERSION|||
+XSprePUSH|5.006000||p
+XS|||
+ZeroD|5.009002||p
+Zero|||
+_aMY_CXT|5.007003||p
+_pMY_CXT|5.007003||p
+aMY_CXT_|5.007003||p
+aMY_CXT|5.007003||p
+aTHXR_|5.011000||p
+aTHXR|5.011000||p
+aTHX_|5.006000||p
+aTHX|5.006000||p
+add_data|||n
+addmad|||
+allocmy|||
+amagic_call|||
+amagic_cmp_locale|||
+amagic_cmp|||
+amagic_i_ncmp|||
+amagic_ncmp|||
+any_dup|||
+ao|||
+append_elem|||
+append_list|||
+append_madprops|||
+apply_attrs_my|||
+apply_attrs_string||5.006001|
+apply_attrs|||
+apply|||
+atfork_lock||5.007003|n
+atfork_unlock||5.007003|n
+av_arylen_p||5.009003|
+av_clear|||
+av_create_and_push||5.009005|
+av_create_and_unshift_one||5.009005|
+av_delete||5.006000|
+av_exists||5.006000|
+av_extend|||
+av_fetch|||
+av_fill|||
+av_iter_p||5.011000|
+av_len|||
+av_make|||
+av_pop|||
+av_push|||
+av_reify|||
+av_shift|||
+av_store|||
+av_undef|||
+av_unshift|||
+ax|||n
+bad_type|||
+bind_match|||
+block_end|||
+block_gimme||5.004000|
+block_start|||
+boolSV|5.004000||p
+boot_core_PerlIO|||
+boot_core_UNIVERSAL|||
+boot_core_mro|||
+bytes_from_utf8||5.007001|
+bytes_to_uni|||n
+bytes_to_utf8||5.006001|
+call_argv|5.006000||p
+call_atexit||5.006000|
+call_list||5.004000|
+call_method|5.006000||p
+call_pv|5.006000||p
+call_sv|5.006000||p
+calloc||5.007002|n
+cando|||
+cast_i32||5.006000|
+cast_iv||5.006000|
+cast_ulong||5.006000|
+cast_uv||5.006000|
+check_type_and_open|||
+check_uni|||
+checkcomma|||
+checkposixcc|||
+ckWARN|5.006000||p
+ck_anoncode|||
+ck_bitop|||
+ck_concat|||
+ck_defined|||
+ck_delete|||
+ck_die|||
+ck_each|||
+ck_eof|||
+ck_eval|||
+ck_exec|||
+ck_exists|||
+ck_exit|||
+ck_ftst|||
+ck_fun|||
+ck_glob|||
+ck_grep|||
+ck_index|||
+ck_join|||
+ck_lfun|||
+ck_listiob|||
+ck_match|||
+ck_method|||
+ck_null|||
+ck_open|||
+ck_readline|||
+ck_repeat|||
+ck_require|||
+ck_return|||
+ck_rfun|||
+ck_rvconst|||
+ck_sassign|||
+ck_select|||
+ck_shift|||
+ck_sort|||
+ck_spair|||
+ck_split|||
+ck_subr|||
+ck_substr|||
+ck_svconst|||
+ck_trunc|||
+ck_unpack|||
+ckwarn_d||5.009003|
+ckwarn||5.009003|
+cl_and|||n
+cl_anything|||n
+cl_init_zero|||n
+cl_init|||n
+cl_is_anything|||n
+cl_or|||n
+clear_placeholders|||
+closest_cop|||
+convert|||
+cop_free|||
+cr_textfilter|||
+create_eval_scope|||
+croak_nocontext|||vn
+croak_xs_usage||5.011000|
+croak|||v
+csighandler||5.009003|n
+curmad|||
+custom_op_desc||5.007003|
+custom_op_name||5.007003|
+cv_ckproto_len|||
+cv_clone|||
+cv_const_sv||5.004000|
+cv_dump|||
+cv_undef|||
+cx_dump||5.005000|
+cx_dup|||
+cxinc|||
+dAXMARK|5.009003||p
+dAX|5.007002||p
+dITEMS|5.007002||p
+dMARK|||
+dMULTICALL||5.009003|
+dMY_CXT_SV|5.007003||p
+dMY_CXT|5.007003||p
+dNOOP|5.006000||p
+dORIGMARK|||
+dSP|||
+dTHR|5.004050||p
+dTHXR|5.011000||p
+dTHXa|5.006000||p
+dTHXoa|5.006000||p
+dTHX|5.006000||p
+dUNDERBAR|5.009002||p
+dVAR|5.009003||p
+dXCPT|5.009002||p
+dXSARGS|||
+dXSI32|||
+dXSTARG|5.006000||p
+deb_curcv|||
+deb_nocontext|||vn
+deb_stack_all|||
+deb_stack_n|||
+debop||5.005000|
+debprofdump||5.005000|
+debprof|||
+debstackptrs||5.007003|
+debstack||5.007003|
+debug_start_match|||
+deb||5.007003|v
+del_sv|||
+delete_eval_scope|||
+delimcpy||5.004000|
+deprecate_old|||
+deprecate|||
+despatch_signals||5.007001|
+destroy_matcher|||
+die_nocontext|||vn
+die_where|||
+die|||v
+dirp_dup|||
+div128|||
+djSP|||
+do_aexec5|||
+do_aexec|||
+do_aspawn|||
+do_binmode||5.004050|
+do_chomp|||
+do_chop|||
+do_close|||
+do_dump_pad|||
+do_eof|||
+do_exec3|||
+do_execfree|||
+do_exec|||
+do_gv_dump||5.006000|
+do_gvgv_dump||5.006000|
+do_hv_dump||5.006000|
+do_ipcctl|||
+do_ipcget|||
+do_join|||
+do_kv|||
+do_magic_dump||5.006000|
+do_msgrcv|||
+do_msgsnd|||
+do_oddball|||
+do_op_dump||5.006000|
+do_op_xmldump|||
+do_open9||5.006000|
+do_openn||5.007001|
+do_open||5.004000|
+do_pmop_dump||5.006000|
+do_pmop_xmldump|||
+do_print|||
+do_readline|||
+do_seek|||
+do_semop|||
+do_shmio|||
+do_smartmatch|||
+do_spawn_nowait|||
+do_spawn|||
+do_sprintf|||
+do_sv_dump||5.006000|
+do_sysseek|||
+do_tell|||
+do_trans_complex_utf8|||
+do_trans_complex|||
+do_trans_count_utf8|||
+do_trans_count|||
+do_trans_simple_utf8|||
+do_trans_simple|||
+do_trans|||
+do_vecget|||
+do_vecset|||
+do_vop|||
+docatch|||
+doeval|||
+dofile|||
+dofindlabel|||
+doform|||
+doing_taint||5.008001|n
+dooneliner|||
+doopen_pm|||
+doparseform|||
+dopoptoeval|||
+dopoptogiven|||
+dopoptolabel|||
+dopoptoloop|||
+dopoptosub_at|||
+dopoptowhen|||
+doref||5.009003|
+dounwind|||
+dowantarray|||
+dump_all||5.006000|
+dump_eval||5.006000|
+dump_exec_pos|||
+dump_fds|||
+dump_form||5.006000|
+dump_indent||5.006000|v
+dump_mstats|||
+dump_packsubs||5.006000|
+dump_sub||5.006000|
+dump_sv_child|||
+dump_trie_interim_list|||
+dump_trie_interim_table|||
+dump_trie|||
+dump_vindent||5.006000|
+dumpuntil|||
+dup_attrlist|||
+emulate_cop_io|||
+eval_pv|5.006000||p
+eval_sv|5.006000||p
+exec_failed|||
+expect_number|||
+fbm_compile||5.005000|
+fbm_instr||5.005000|
+feature_is_enabled|||
+fetch_cop_label||5.011000|
+filter_add|||
+filter_del|||
+filter_gets|||
+filter_read|||
+find_and_forget_pmops|||
+find_array_subscript|||
+find_beginning|||
+find_byclass|||
+find_hash_subscript|||
+find_in_my_stash|||
+find_runcv||5.008001|
+find_rundefsvoffset||5.009002|
+find_script|||
+find_uninit_var|||
+first_symbol|||n
+fold_constants|||
+forbid_setid|||
+force_ident|||
+force_list|||
+force_next|||
+force_version|||
+force_word|||
+forget_pmop|||
+form_nocontext|||vn
+form||5.004000|v
+fp_dup|||
+fprintf_nocontext|||vn
+free_global_struct|||
+free_tied_hv_pool|||
+free_tmps|||
+gen_constant_list|||
+get_arena|||
+get_aux_mg|||
+get_av|5.006000||p
+get_context||5.006000|n
+get_cvn_flags||5.009005|
+get_cv|5.006000||p
+get_db_sub|||
+get_debug_opts|||
+get_hash_seed|||
+get_hv|5.006000||p
+get_isa_hash|||
+get_mstats|||
+get_no_modify|||
+get_num|||
+get_op_descs||5.005000|
+get_op_names||5.005000|
+get_opargs|||
+get_ppaddr||5.006000|
+get_re_arg|||
+get_sv|5.006000||p
+get_vtbl||5.005030|
+getcwd_sv||5.007002|
+getenv_len|||
+glob_2number|||
+glob_assign_glob|||
+glob_assign_ref|||
+gp_dup|||
+gp_free|||
+gp_ref|||
+grok_bin|5.007003||p
+grok_hex|5.007003||p
+grok_number|5.007002||p
+grok_numeric_radix|5.007002||p
+grok_oct|5.007003||p
+group_end|||
+gv_AVadd|||
+gv_HVadd|||
+gv_IOadd|||
+gv_SVadd|||
+gv_autoload4||5.004000|
+gv_check|||
+gv_const_sv||5.009003|
+gv_dump||5.006000|
+gv_efullname3||5.004000|
+gv_efullname4||5.006001|
+gv_efullname|||
+gv_ename|||
+gv_fetchfile_flags||5.009005|
+gv_fetchfile|||
+gv_fetchmeth_autoload||5.007003|
+gv_fetchmethod_autoload||5.004000|
+gv_fetchmethod_flags||5.011000|
+gv_fetchmethod|||
+gv_fetchmeth|||
+gv_fetchpvn_flags|5.009002||p
+gv_fetchpvs|5.009004||p
+gv_fetchpv|||
+gv_fetchsv||5.009002|
+gv_fullname3||5.004000|
+gv_fullname4||5.006001|
+gv_fullname|||
+gv_get_super_pkg|||
+gv_handler||5.007001|
+gv_init_sv|||
+gv_init|||
+gv_name_set||5.009004|
+gv_stashpvn|5.004000||p
+gv_stashpvs|5.009003||p
+gv_stashpv|||
+gv_stashsv|||
+he_dup|||
+hek_dup|||
+hfreeentries|||
+hsplit|||
+hv_assert||5.011000|
+hv_auxinit|||n
+hv_backreferences_p|||
+hv_clear_placeholders||5.009001|
+hv_clear|||
+hv_common_key_len||5.010000|
+hv_common||5.010000|
+hv_copy_hints_hv|||
+hv_delayfree_ent||5.004000|
+hv_delete_common|||
+hv_delete_ent||5.004000|
+hv_delete|||
+hv_eiter_p||5.009003|
+hv_eiter_set||5.009003|
+hv_exists_ent||5.004000|
+hv_exists|||
+hv_fetch_ent||5.004000|
+hv_fetchs|5.009003||p
+hv_fetch|||
+hv_free_ent||5.004000|
+hv_iterinit|||
+hv_iterkeysv||5.004000|
+hv_iterkey|||
+hv_iternext_flags||5.008000|
+hv_iternextsv|||
+hv_iternext|||
+hv_iterval|||
+hv_kill_backrefs|||
+hv_ksplit||5.004000|
+hv_magic_check|||n
+hv_magic|||
+hv_name_set||5.009003|
+hv_notallowed|||
+hv_placeholders_get||5.009003|
+hv_placeholders_p||5.009003|
+hv_placeholders_set||5.009003|
+hv_riter_p||5.009003|
+hv_riter_set||5.009003|
+hv_scalar||5.009001|
+hv_store_ent||5.004000|
+hv_store_flags||5.008000|
+hv_stores|5.009004||p
+hv_store|||
+hv_undef|||
+ibcmp_locale||5.004000|
+ibcmp_utf8||5.007003|
+ibcmp|||
+incline|||
+incpush_if_exists|||
+incpush_use_sep|||
+incpush|||
+ingroup|||
+init_argv_symbols|||
+init_debugger|||
+init_global_struct|||
+init_i18nl10n||5.006000|
+init_i18nl14n||5.006000|
+init_ids|||
+init_interp|||
+init_main_stash|||
+init_perllib|||
+init_postdump_symbols|||
+init_predump_symbols|||
+init_stacks||5.005000|
+init_tm||5.007002|
+instr|||
+intro_my|||
+intuit_method|||
+intuit_more|||
+invert|||
+io_close|||
+isALNUMC|5.006000||p
+isALNUM|||
+isALPHA|||
+isASCII|5.006000||p
+isBLANK|5.006001||p
+isCNTRL|5.006000||p
+isDIGIT|||
+isGRAPH|5.006000||p
+isGV_with_GP|5.009004||p
+isLOWER|||
+isPRINT|5.004000||p
+isPSXSPC|5.006001||p
+isPUNCT|5.006000||p
+isSPACE|||
+isUPPER|||
+isXDIGIT|5.006000||p
+is_an_int|||
+is_gv_magical_sv|||
+is_handle_constructor|||n
+is_list_assignment|||
+is_lvalue_sub||5.007001|
+is_uni_alnum_lc||5.006000|
+is_uni_alnumc_lc||5.006000|
+is_uni_alnumc||5.006000|
+is_uni_alnum||5.006000|
+is_uni_alpha_lc||5.006000|
+is_uni_alpha||5.006000|
+is_uni_ascii_lc||5.006000|
+is_uni_ascii||5.006000|
+is_uni_cntrl_lc||5.006000|
+is_uni_cntrl||5.006000|
+is_uni_digit_lc||5.006000|
+is_uni_digit||5.006000|
+is_uni_graph_lc||5.006000|
+is_uni_graph||5.006000|
+is_uni_idfirst_lc||5.006000|
+is_uni_idfirst||5.006000|
+is_uni_lower_lc||5.006000|
+is_uni_lower||5.006000|
+is_uni_print_lc||5.006000|
+is_uni_print||5.006000|
+is_uni_punct_lc||5.006000|
+is_uni_punct||5.006000|
+is_uni_space_lc||5.006000|
+is_uni_space||5.006000|
+is_uni_upper_lc||5.006000|
+is_uni_upper||5.006000|
+is_uni_xdigit_lc||5.006000|
+is_uni_xdigit||5.006000|
+is_utf8_alnumc||5.006000|
+is_utf8_alnum||5.006000|
+is_utf8_alpha||5.006000|
+is_utf8_ascii||5.006000|
+is_utf8_char_slow|||n
+is_utf8_char||5.006000|
+is_utf8_cntrl||5.006000|
+is_utf8_common|||
+is_utf8_digit||5.006000|
+is_utf8_graph||5.006000|
+is_utf8_idcont||5.008000|
+is_utf8_idfirst||5.006000|
+is_utf8_lower||5.006000|
+is_utf8_mark||5.006000|
+is_utf8_print||5.006000|
+is_utf8_punct||5.006000|
+is_utf8_space||5.006000|
+is_utf8_string_loclen||5.009003|
+is_utf8_string_loc||5.008001|
+is_utf8_string||5.006001|
+is_utf8_upper||5.006000|
+is_utf8_xdigit||5.006000|
+isa_lookup|||
+items|||n
+ix|||n
+jmaybe|||
+join_exact|||
+keyword|||
+leave_scope|||
+lex_end|||
+lex_start|||
+linklist|||
+listkids|||
+list|||
+load_module_nocontext|||vn
+load_module|5.006000||pv
+localize|||
+looks_like_bool|||
+looks_like_number|||
+lop|||
+mPUSHi|5.009002||p
+mPUSHn|5.009002||p
+mPUSHp|5.009002||p
+mPUSHs|5.011000||p
+mPUSHu|5.009002||p
+mXPUSHi|5.009002||p
+mXPUSHn|5.009002||p
+mXPUSHp|5.009002||p
+mXPUSHs|5.011000||p
+mXPUSHu|5.009002||p
+mad_free|||
+madlex|||
+madparse|||
+magic_clear_all_env|||
+magic_clearenv|||
+magic_clearhint|||
+magic_clearisa|||
+magic_clearpack|||
+magic_clearsig|||
+magic_dump||5.006000|
+magic_existspack|||
+magic_freearylen_p|||
+magic_freeovrld|||
+magic_getarylen|||
+magic_getdefelem|||
+magic_getnkeys|||
+magic_getpack|||
+magic_getpos|||
+magic_getsig|||
+magic_getsubstr|||
+magic_gettaint|||
+magic_getuvar|||
+magic_getvec|||
+magic_get|||
+magic_killbackrefs|||
+magic_len|||
+magic_methcall|||
+magic_methpack|||
+magic_nextpack|||
+magic_regdata_cnt|||
+magic_regdatum_get|||
+magic_regdatum_set|||
+magic_scalarpack|||
+magic_set_all_env|||
+magic_setamagic|||
+magic_setarylen|||
+magic_setcollxfrm|||
+magic_setdbline|||
+magic_setdefelem|||
+magic_setenv|||
+magic_sethint|||
+magic_setisa|||
+magic_setmglob|||
+magic_setnkeys|||
+magic_setpack|||
+magic_setpos|||
+magic_setregexp|||
+magic_setsig|||
+magic_setsubstr|||
+magic_settaint|||
+magic_setutf8|||
+magic_setuvar|||
+magic_setvec|||
+magic_set|||
+magic_sizepack|||
+magic_wipepack|||
+make_matcher|||
+make_trie_failtable|||
+make_trie|||
+malloc_good_size|||n
+malloced_size|||n
+malloc||5.007002|n
+markstack_grow|||
+matcher_matches_sv|||
+measure_struct|||
+memEQ|5.004000||p
+memNE|5.004000||p
+mem_collxfrm|||
+mem_log_common|||n
+mess_alloc|||
+mess_nocontext|||vn
+mess||5.006000|v
+method_common|||
+mfree||5.007002|n
+mg_clear|||
+mg_copy|||
+mg_dup|||
+mg_find|||
+mg_free|||
+mg_get|||
+mg_length||5.005000|
+mg_localize|||
+mg_magical|||
+mg_set|||
+mg_size||5.005000|
+mini_mktime||5.007002|
+missingterm|||
+mode_from_discipline|||
+modkids|||
+mod|||
+more_bodies|||
+more_sv|||
+moreswitches|||
+mro_get_from_name||5.011000|
+mro_get_linear_isa_dfs|||
+mro_get_linear_isa||5.009005|
+mro_get_private_data||5.011000|
+mro_isa_changed_in|||
+mro_meta_dup|||
+mro_meta_init|||
+mro_method_changed_in||5.009005|
+mro_register||5.011000|
+mro_set_mro||5.011000|
+mro_set_private_data||5.011000|
+mul128|||
+mulexp10|||n
+my_atof2||5.007002|
+my_atof||5.006000|
+my_attrs|||
+my_bcopy|||n
+my_betoh16|||n
+my_betoh32|||n
+my_betoh64|||n
+my_betohi|||n
+my_betohl|||n
+my_betohs|||n
+my_bzero|||n
+my_chsize|||
+my_clearenv|||
+my_cxt_index|||
+my_cxt_init|||
+my_dirfd||5.009005|
+my_exit_jump|||
+my_exit|||
+my_failure_exit||5.004000|
+my_fflush_all||5.006000|
+my_fork||5.007003|n
+my_htobe16|||n
+my_htobe32|||n
+my_htobe64|||n
+my_htobei|||n
+my_htobel|||n
+my_htobes|||n
+my_htole16|||n
+my_htole32|||n
+my_htole64|||n
+my_htolei|||n
+my_htolel|||n
+my_htoles|||n
+my_htonl|||
+my_kid|||
+my_letoh16|||n
+my_letoh32|||n
+my_letoh64|||n
+my_letohi|||n
+my_letohl|||n
+my_letohs|||n
+my_lstat|||
+my_memcmp||5.004000|n
+my_memset|||n
+my_ntohl|||
+my_pclose||5.004000|
+my_popen_list||5.007001|
+my_popen||5.004000|
+my_setenv|||
+my_snprintf|5.009004||pvn
+my_socketpair||5.007003|n
+my_sprintf|5.009003||pvn
+my_stat|||
+my_strftime||5.007002|
+my_strlcat|5.009004||pn
+my_strlcpy|5.009004||pn
+my_swabn|||n
+my_swap|||
+my_unexec|||
+my_vsnprintf||5.009004|n
+need_utf8|||n
+newANONATTRSUB||5.006000|
+newANONHASH|||
+newANONLIST|||
+newANONSUB|||
+newASSIGNOP|||
+newATTRSUB||5.006000|
+newAVREF|||
+newAV|||
+newBINOP|||
+newCONDOP|||
+newCONSTSUB|5.004050||p
+newCVREF|||
+newDEFSVOP|||
+newFORM|||
+newFOROP|||
+newGIVENOP||5.009003|
+newGIVWHENOP|||
+newGP|||
+newGVOP|||
+newGVREF|||
+newGVgen|||
+newHVREF|||
+newHVhv||5.005000|
+newHV|||
+newIO|||
+newLISTOP|||
+newLOGOP|||
+newLOOPEX|||
+newLOOPOP|||
+newMADPROP|||
+newMADsv|||
+newMYSUB|||
+newNULLLIST|||
+newOP|||
+newPADOP|||
+newPMOP|||
+newPROG|||
+newPVOP|||
+newRANGE|||
+newRV_inc|5.004000||p
+newRV_noinc|5.004000||p
+newRV|||
+newSLICEOP|||
+newSTATEOP|||
+newSUB|||
+newSVOP|||
+newSVREF|||
+newSV_type|5.009005||p
+newSVhek||5.009003|
+newSViv|||
+newSVnv|||
+newSVpvf_nocontext|||vn
+newSVpvf||5.004000|v
+newSVpvn_flags|5.011000||p
+newSVpvn_share|5.007001||p
+newSVpvn_utf8|5.011000||p
+newSVpvn|5.004050||p
+newSVpvs_flags|5.011000||p
+newSVpvs_share||5.009003|
+newSVpvs|5.009003||p
+newSVpv|||
+newSVrv|||
+newSVsv|||
+newSVuv|5.006000||p
+newSV|||
+newTOKEN|||
+newUNOP|||
+newWHENOP||5.009003|
+newWHILEOP||5.009003|
+newXS_flags||5.009004|
+newXSproto||5.006000|
+newXS||5.006000|
+new_collate||5.006000|
+new_constant|||
+new_ctype||5.006000|
+new_he|||
+new_logop|||
+new_numeric||5.006000|
+new_stackinfo||5.005000|
+new_version||5.009000|
+new_warnings_bitfield|||
+next_symbol|||
+nextargv|||
+nextchar|||
+ninstr|||
+no_bareword_allowed|||
+no_fh_allowed|||
+no_op|||
+not_a_number|||
+nothreadhook||5.008000|
+nuke_stacks|||
+num_overflow|||n
+offer_nice_chunk|||
+oopsAV|||
+oopsHV|||
+op_clear|||
+op_const_sv|||
+op_dump||5.006000|
+op_free|||
+op_getmad_weak|||
+op_getmad|||
+op_null||5.007002|
+op_refcnt_dec|||
+op_refcnt_inc|||
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
+op_xmldump|||
+open_script|||
+pMY_CXT_|5.007003||p
+pMY_CXT|5.007003||p
+pTHX_|5.006000||p
+pTHX|5.006000||p
+packWARN|5.007003||p
+pack_cat||5.007003|
+pack_rec|||
+package|||
+packlist||5.008001|
+pad_add_anon|||
+pad_add_name|||
+pad_alloc|||
+pad_block_start|||
+pad_check_dup|||
+pad_compname_type|||
+pad_findlex|||
+pad_findmy|||
+pad_fixup_inner_anons|||
+pad_free|||
+pad_leavemy|||
+pad_new|||
+pad_peg|||n
+pad_push|||
+pad_reset|||
+pad_setsv|||
+pad_sv||5.011000|
+pad_swipe|||
+pad_tidy|||
+pad_undef|||
+parse_body|||
+parse_unicode_opts|||
+parser_dup|||
+parser_free|||
+path_is_absolute|||n
+peep|||
+pending_Slabs_to_ro|||
+perl_alloc_using|||n
+perl_alloc|||n
+perl_clone_using|||n
+perl_clone|||n
+perl_construct|||n
+perl_destruct||5.007003|n
+perl_free|||n
+perl_parse||5.006000|n
+perl_run|||n
+pidgone|||
+pm_description|||
+pmflag|||
+pmop_dump||5.006000|
+pmop_xmldump|||
+pmruntime|||
+pmtrans|||
+pop_scope|||
+pregcomp||5.009005|
+pregexec|||
+pregfree2||5.011000|
+pregfree|||
+prepend_elem|||
+prepend_madprops|||
+printbuf|||
+printf_nocontext|||vn
+process_special_blocks|||
+ptr_table_clear||5.009005|
+ptr_table_fetch||5.009005|
+ptr_table_find|||n
+ptr_table_free||5.009005|
+ptr_table_new||5.009005|
+ptr_table_split||5.009005|
+ptr_table_store||5.009005|
+push_scope|||
+put_byte|||
+pv_display|5.006000||p
+pv_escape|5.009004||p
+pv_pretty|5.009004||p
+pv_uni_display||5.007003|
+qerror|||
+qsortsvu|||
+re_compile||5.009005|
+re_croak2|||
+re_dup_guts|||
+re_intuit_start||5.009005|
+re_intuit_string||5.006000|
+readpipe_override|||
+realloc||5.007002|n
+reentrant_free|||
+reentrant_init|||
+reentrant_retry|||vn
+reentrant_size|||
+ref_array_or_hash|||
+refcounted_he_chain_2hv|||
+refcounted_he_fetch|||
+refcounted_he_free|||
+refcounted_he_new_common|||
+refcounted_he_new|||
+refcounted_he_value|||
+refkids|||
+refto|||
+ref||5.011000|
+reg_check_named_buff_matched|||
+reg_named_buff_all||5.009005|
+reg_named_buff_exists||5.009005|
+reg_named_buff_fetch||5.009005|
+reg_named_buff_firstkey||5.009005|
+reg_named_buff_iter|||
+reg_named_buff_nextkey||5.009005|
+reg_named_buff_scalar||5.009005|
+reg_named_buff|||
+reg_namedseq|||
+reg_node|||
+reg_numbered_buff_fetch|||
+reg_numbered_buff_length|||
+reg_numbered_buff_store|||
+reg_qr_package|||
+reg_recode|||
+reg_scan_name|||
+reg_skipcomment|||
+reg_temp_copy|||
+reganode|||
+regatom|||
+regbranch|||
+regclass_swash||5.009004|
+regclass|||
+regcppop|||
+regcppush|||
+regcurly|||n
+regdump_extflags|||
+regdump||5.005000|
+regdupe_internal|||
+regexec_flags||5.005000|
+regfree_internal||5.009005|
+reghop3|||n
+reghop4|||n
+reghopmaybe3|||n
+reginclass|||
+reginitcolors||5.006000|
+reginsert|||
+regmatch|||
+regnext||5.005000|
+regpiece|||
+regpposixcc|||
+regprop|||
+regrepeat|||
+regtail_study|||
+regtail|||
+regtry|||
+reguni|||
+regwhite|||n
+reg|||
+repeatcpy|||
+report_evil_fh|||
+report_uninit|||
+require_pv||5.006000|
+require_tie_mod|||
+restore_magic|||
+rninstr|||
+rsignal_restore|||
+rsignal_save|||
+rsignal_state||5.004000|
+rsignal||5.004000|
+run_body|||
+run_user_filter|||
+runops_debug||5.005000|
+runops_standard||5.005000|
+rvpv_dup|||
+rxres_free|||
+rxres_restore|||
+rxres_save|||
+safesyscalloc||5.006000|n
+safesysfree||5.006000|n
+safesysmalloc||5.006000|n
+safesysrealloc||5.006000|n
+same_dirent|||
+save_I16||5.004000|
+save_I32|||
+save_I8||5.006000|
+save_adelete||5.011000|
+save_aelem||5.004050|
+save_alloc||5.006000|
+save_aptr|||
+save_ary|||
+save_bool||5.008001|
+save_clearsv|||
+save_delete|||
+save_destructor_x||5.006000|
+save_destructor||5.006000|
+save_freeop|||
+save_freepv|||
+save_freesv|||
+save_generic_pvref||5.006001|
+save_generic_svref||5.005030|
+save_gp||5.004000|
+save_hash|||
+save_hek_flags|||n
+save_helem_flags||5.011000|
+save_helem||5.004050|
+save_hints|||
+save_hptr|||
+save_int|||
+save_item|||
+save_iv||5.005000|
+save_lines|||
+save_list|||
+save_long|||
+save_magic|||
+save_mortalizesv||5.007001|
+save_nogv|||
+save_op|||
+save_padsv_and_mortalize||5.011000|
+save_pptr|||
+save_pushi32ptr|||
+save_pushptri32ptr|||
+save_pushptrptr|||
+save_pushptr||5.011000|
+save_re_context||5.006000|
+save_scalar_at|||
+save_scalar|||
+save_set_svflags||5.009000|
+save_shared_pvref||5.007003|
+save_sptr|||
+save_svref|||
+save_vptr||5.006000|
+savepvn|||
+savepvs||5.009003|
+savepv|||
+savesharedpvn||5.009005|
+savesharedpv||5.007003|
+savestack_grow_cnt||5.008001|
+savestack_grow|||
+savesvpv||5.009002|
+sawparens|||
+scalar_mod_type|||n
+scalarboolean|||
+scalarkids|||
+scalarseq|||
+scalarvoid|||
+scalar|||
+scan_bin||5.006000|
+scan_commit|||
+scan_const|||
+scan_formline|||
+scan_heredoc|||
+scan_hex|||
+scan_ident|||
+scan_inputsymbol|||
+scan_num||5.007001|
+scan_oct|||
+scan_pat|||
+scan_str|||
+scan_subst|||
+scan_trans|||
+scan_version||5.009001|
+scan_vstring||5.009005|
+scan_word|||
+scope|||
+screaminstr||5.005000|
+search_const|||
+seed||5.008001|
+sequence_num|||
+sequence_tail|||
+sequence|||
+set_context||5.006000|n
+set_numeric_local||5.006000|
+set_numeric_radix||5.006000|
+set_numeric_standard||5.006000|
+setdefout|||
+share_hek_flags|||
+share_hek||5.004000|
+si_dup|||
+sighandler|||n
+simplify_sort|||
+skipspace0|||
+skipspace1|||
+skipspace2|||
+skipspace|||
+softref2xv|||
+sortcv_stacked|||
+sortcv_xsub|||
+sortcv|||
+sortsv_flags||5.009003|
+sortsv||5.007003|
+space_join_names_mortal|||
+ss_dup|||
+stack_grow|||
+start_force|||
+start_glob|||
+start_subparse||5.004000|
+stashpv_hvname_match||5.011000|
+stdize_locale|||
+store_cop_label|||
+strEQ|||
+strGE|||
+strGT|||
+strLE|||
+strLT|||
+strNE|||
+str_to_version||5.006000|
+strip_return|||
+strnEQ|||
+strnNE|||
+study_chunk|||
+sub_crush_depth|||
+sublex_done|||
+sublex_push|||
+sublex_start|||
+sv_2bool|||
+sv_2cv|||
+sv_2io|||
+sv_2iuv_common|||
+sv_2iuv_non_preserve|||
+sv_2iv_flags||5.009001|
+sv_2iv|||
+sv_2mortal|||
+sv_2num|||
+sv_2nv|||
+sv_2pv_flags|5.007002||p
+sv_2pv_nolen|5.006000||p
+sv_2pvbyte_nolen|5.006000||p
+sv_2pvbyte|5.006000||p
+sv_2pvutf8_nolen||5.006000|
+sv_2pvutf8||5.006000|
+sv_2pv|||
+sv_2uv_flags||5.009001|
+sv_2uv|5.004000||p
+sv_add_arena|||
+sv_add_backref|||
+sv_backoff|||
+sv_bless|||
+sv_cat_decode||5.008001|
+sv_catpv_mg|5.004050||p
+sv_catpvf_mg_nocontext|||pvn
+sv_catpvf_mg|5.006000|5.004000|pv
+sv_catpvf_nocontext|||vn
+sv_catpvf||5.004000|v
+sv_catpvn_flags||5.007002|
+sv_catpvn_mg|5.004050||p
+sv_catpvn_nomg|5.007002||p
+sv_catpvn|||
+sv_catpvs|5.009003||p
+sv_catpv|||
+sv_catsv_flags||5.007002|
+sv_catsv_mg|5.004050||p
+sv_catsv_nomg|5.007002||p
+sv_catsv|||
+sv_catxmlpvn|||
+sv_catxmlsv|||
+sv_chop|||
+sv_clean_all|||
+sv_clean_objs|||
+sv_clear|||
+sv_cmp_locale||5.004000|
+sv_cmp|||
+sv_collxfrm|||
+sv_compile_2op||5.008001|
+sv_copypv||5.007003|
+sv_dec|||
+sv_del_backref|||
+sv_derived_from||5.004000|
+sv_destroyable||5.010000|
+sv_does||5.009004|
+sv_dump|||
+sv_dup_inc_multiple|||
+sv_dup|||
+sv_eq|||
+sv_exp_grow|||
+sv_force_normal_flags||5.007001|
+sv_force_normal||5.006000|
+sv_free2|||
+sv_free_arenas|||
+sv_free|||
+sv_gets||5.004000|
+sv_grow|||
+sv_i_ncmp|||
+sv_inc|||
+sv_insert_flags||5.011000|
+sv_insert|||
+sv_isa|||
+sv_isobject|||
+sv_iv||5.005000|
+sv_kill_backrefs|||
+sv_len_utf8||5.006000|
+sv_len|||
+sv_magic_portable|5.011000|5.004000|p
+sv_magicext||5.007003|
+sv_magic|||
+sv_mortalcopy|||
+sv_ncmp|||
+sv_newmortal|||
+sv_newref|||
+sv_nolocking||5.007003|
+sv_nosharing||5.007003|
+sv_nounlocking|||
+sv_nv||5.005000|
+sv_peek||5.005000|
+sv_pos_b2u_midway|||
+sv_pos_b2u||5.006000|
+sv_pos_u2b_cached|||
+sv_pos_u2b_forwards|||n
+sv_pos_u2b_midway|||n
+sv_pos_u2b||5.006000|
+sv_pvbyten_force||5.006000|
+sv_pvbyten||5.006000|
+sv_pvbyte||5.006000|
+sv_pvn_force_flags|5.007002||p
+sv_pvn_force|||
+sv_pvn_nomg|5.007003|5.005000|p
+sv_pvn||5.005000|
+sv_pvutf8n_force||5.006000|
+sv_pvutf8n||5.006000|
+sv_pvutf8||5.006000|
+sv_pv||5.006000|
+sv_recode_to_utf8||5.007003|
+sv_reftype|||
+sv_release_COW|||
+sv_replace|||
+sv_report_used|||
+sv_reset|||
+sv_rvweaken||5.006000|
+sv_setiv_mg|5.004050||p
+sv_setiv|||
+sv_setnv_mg|5.006000||p
+sv_setnv|||
+sv_setpv_mg|5.004050||p
+sv_setpvf_mg_nocontext|||pvn
+sv_setpvf_mg|5.006000|5.004000|pv
+sv_setpvf_nocontext|||vn
+sv_setpvf||5.004000|v
+sv_setpviv_mg||5.008001|
+sv_setpviv||5.008001|
+sv_setpvn_mg|5.004050||p
+sv_setpvn|||
+sv_setpvs|5.009004||p
+sv_setpv|||
+sv_setref_iv|||
+sv_setref_nv|||
+sv_setref_pvn|||
+sv_setref_pv|||
+sv_setref_uv||5.007001|
+sv_setsv_cow|||
+sv_setsv_flags||5.007002|
+sv_setsv_mg|5.004050||p
+sv_setsv_nomg|5.007002||p
+sv_setsv|||
+sv_setuv_mg|5.004050||p
+sv_setuv|5.004000||p
+sv_tainted||5.004000|
+sv_taint||5.004000|
+sv_true||5.005000|
+sv_unglob|||
+sv_uni_display||5.007003|
+sv_unmagic|||
+sv_unref_flags||5.007001|
+sv_unref|||
+sv_untaint||5.004000|
+sv_upgrade|||
+sv_usepvn_flags||5.009004|
+sv_usepvn_mg|5.004050||p
+sv_usepvn|||
+sv_utf8_decode||5.006000|
+sv_utf8_downgrade||5.006000|
+sv_utf8_encode||5.006000|
+sv_utf8_upgrade_flags_grow||5.011000|
+sv_utf8_upgrade_flags||5.007002|
+sv_utf8_upgrade_nomg||5.007002|
+sv_utf8_upgrade||5.007001|
+sv_uv|5.005000||p
+sv_vcatpvf_mg|5.006000|5.004000|p
+sv_vcatpvfn||5.004000|
+sv_vcatpvf|5.006000|5.004000|p
+sv_vsetpvf_mg|5.006000|5.004000|p
+sv_vsetpvfn||5.004000|
+sv_vsetpvf|5.006000|5.004000|p
+sv_xmlpeek|||
+svtype|||
+swallow_bom|||
+swap_match_buff|||
+swash_fetch||5.007002|
+swash_get|||
+swash_init||5.006000|
+sys_init3||5.010000|n
+sys_init||5.010000|n
+sys_intern_clear|||
+sys_intern_dup|||
+sys_intern_init|||
+sys_term||5.010000|n
+taint_env|||
+taint_proper|||
+tmps_grow||5.006000|
+toLOWER|||
+toUPPER|||
+to_byte_substr|||
+to_uni_fold||5.007003|
+to_uni_lower_lc||5.006000|
+to_uni_lower||5.007003|
+to_uni_title_lc||5.006000|
+to_uni_title||5.007003|
+to_uni_upper_lc||5.006000|
+to_uni_upper||5.007003|
+to_utf8_case||5.007003|
+to_utf8_fold||5.007003|
+to_utf8_lower||5.007003|
+to_utf8_substr|||
+to_utf8_title||5.007003|
+to_utf8_upper||5.007003|
+token_free|||
+token_getmad|||
+tokenize_use|||
+tokeq|||
+tokereport|||
+too_few_arguments|||
+too_many_arguments|||
+uiv_2buf|||n
+unlnk|||
+unpack_rec|||
+unpack_str||5.007003|
+unpackstring||5.008001|
+unshare_hek_or_pvn|||
+unshare_hek|||
+unsharepvn||5.004000|
+unwind_handler_stack|||
+update_debugger_info|||
+upg_version||5.009005|
+usage|||
+utf16_to_utf8_reversed||5.006001|
+utf16_to_utf8||5.006001|
+utf8_distance||5.006000|
+utf8_hop||5.006000|
+utf8_length||5.007001|
+utf8_mg_pos_cache_update|||
+utf8_to_bytes||5.006001|
+utf8_to_uvchr||5.007001|
+utf8_to_uvuni||5.007001|
+utf8n_to_uvchr|||
+utf8n_to_uvuni||5.007001|
+utilize|||
+uvchr_to_utf8_flags||5.007003|
+uvchr_to_utf8|||
+uvuni_to_utf8_flags||5.007003|
+uvuni_to_utf8||5.007001|
+validate_suid|||
+varname|||
+vcmp||5.009000|
+vcroak||5.006000|
+vdeb||5.007003|
+vdie_common|||
+vdie_croak_common|||
+vdie|||
+vform||5.006000|
+visit|||
+vivify_defelem|||
+vivify_ref|||
+vload_module|5.006000||p
+vmess||5.006000|
+vnewSVpvf|5.006000|5.004000|p
+vnormal||5.009002|
+vnumify||5.009000|
+vstringify||5.009000|
+vverify||5.009003|
+vwarner||5.006000|
+vwarn||5.006000|
+wait4pid|||
+warn_nocontext|||vn
+warner_nocontext|||vn
+warner|5.006000|5.004000|pv
+warn|||v
+watch|||
+whichsig|||
+write_no_mem|||
+write_to_stderr|||
+xmldump_all|||
+xmldump_attr|||
+xmldump_eval|||
+xmldump_form|||
+xmldump_indent|||v
+xmldump_packsubs|||
+xmldump_sub|||
+xmldump_vindent|||
+yyerror|||
+yylex|||
+yyparse|||
+yywarn|||
+);
+
+if (exists $opt{'list-unsupported'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{todo};
+ print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
+ }
+ exit 0;
+}
+
+# Scan for possible replacement candidates
+
+my(%replace, %need, %hints, %warnings, %depends);
+my $replace = 0;
+my($hint, $define, $function);
+
+sub find_api
+{
+ my $code = shift;
+ $code =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
+ grep { exists $API{$_} } $code =~ /(\w+)/mg;
+}
+
+while (<DATA>) {
+ if ($hint) {
+ my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
+ if (m{^\s*\*\s(.*?)\s*$}) {
+ for (@{$hint->[1]}) {
+ $h->{$_} ||= ''; # suppress warning with older perls
+ $h->{$_} .= "$1\n";
+ }
+ }
+ else { undef $hint }
+ }
+
+ $hint = [$1, [split /,?\s+/, $2]]
+ if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
+
+ if ($define) {
+ if ($define->[1] =~ /\\$/) {
+ $define->[1] .= $_;
+ }
+ else {
+ if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
+ my @n = find_api($define->[1]);
+ push @{$depends{$define->[0]}}, @n if @n
+ }
+ undef $define;
+ }
+ }
+
+ $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
+
+ if ($function) {
+ if (/^}/) {
+ if (exists $API{$function->[0]}) {
+ my @n = find_api($function->[1]);
+ push @{$depends{$function->[0]}}, @n if @n
+ }
+ undef $function;
+ }
+ else {
+ $function->[1] .= $_;
+ }
+ }
+
+ $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
+
+ $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
+ $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
+ $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
+ $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
+
+ if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
+ my @deps = map { s/\s+//g; $_ } split /,/, $3;
+ my $d;
+ for $d (map { s/\s+//g; $_ } split /,/, $1) {
+ push @{$depends{$d}}, @deps;
+ }
+ }
+
+ $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
+}
+
+for (values %depends) {
+ my %s;
+ $_ = [sort grep !$s{$_}++, @$_];
+}
+
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "\n$hints{$f}" if exists $hints{$f};
+ print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
+ $info++;
+ }
+ print "No portability information available.\n" unless $info;
+ $count++;
+ }
+ $count or print "Found no API matching '$opt{'api-info'}'.";
+ print "\n";
+ exit 0;
+}
+
+if (exists $opt{'list-provided'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{provided};
+ my @flags;
+ push @flags, 'explicit' if exists $need{$f};
+ push @flags, 'depend' if exists $depends{$f};
+ push @flags, 'hint' if exists $hints{$f};
+ push @flags, 'warning' if exists $warnings{$f};
+ my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
+ print "$f$flags\n";
+ }
+ exit 0;
+}
+
+my @files;
+my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
+my $srcext = join '|', map { quotemeta $_ } @srcext;
+
+if (@ARGV) {
+ my %seen;
+ for (@ARGV) {
+ if (-e) {
+ if (-f) {
+ push @files, $_ unless $seen{$_}++;
+ }
+ else { warn "'$_' is not a file.\n" }
+ }
+ else {
+ my @new = grep { -f } glob $_
+ or warn "'$_' does not exist.\n";
+ push @files, grep { !$seen{$_}++ } @new;
+ }
+ }
+}
+else {
+ eval {
+ require File::Find;
+ File::Find::find(sub {
+ $File::Find::name =~ /($srcext)$/i
+ and push @files, $File::Find::name;
+ }, '.');
+ };
+ if ($@) {
+ @files = map { glob "*$_" } @srcext;
+ }
+}
+
+if (!@ARGV || $opt{filter}) {
+ my(@in, @out);
+ my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
+ for (@files) {
+ my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
+ push @{ $out ? \@out : \@in }, $_;
+ }
+ if (@ARGV && @out) {
+ warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
+ }
+ @files = @in;
+}
+
+die "No input files given!\n" unless @files;
+
+my(%files, %global, %revreplace);
+%revreplace = reverse %replace;
+my $filename;
+my $patch_opened = 0;
+
+for $filename (@files) {
+ unless (open IN, "<$filename") {
+ warn "Unable to read from $filename: $!\n";
+ next;
+ }
+
+ info("Scanning $filename ...");
+
+ my $c = do { local $/; <IN> };
+ close IN;
+
+ my %file = (orig => $c, changes => 0);
+
+ # Temporarily remove C/XS comments and strings from the code
+ my @ccom;
+
+ $c =~ s{
+ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
+ | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
+ | ( ^$HS*\#[^\r\n]*
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*'
+ | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
+ }{ defined $2 and push @ccom, $2;
+ defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
+
+ $file{ccom} = \@ccom;
+ $file{code} = $c;
+ $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
+
+ my $func;
+
+ for $func (keys %API) {
+ my $match = $func;
+ $match .= "|$revreplace{$func}" if exists $revreplace{$func};
+ if ($c =~ /\b(?:Perl_)?($match)\b/) {
+ $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
+ $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
+ if (exists $API{$func}{provided}) {
+ $file{uses_provided}{$func}++;
+ if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
+ $file{uses}{$func}++;
+ my @deps = rec_depend($func);
+ if (@deps) {
+ $file{uses_deps}{$func} = \@deps;
+ for (@deps) {
+ $file{uses}{$_} = 0 unless exists $file{uses}{$_};
+ }
+ }
+ for ($func, @deps) {
+ $file{needs}{$_} = 'static' if exists $need{$_};
+ }
+ }
+ }
+ if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
+ if ($c =~ /\b$func\b/) {
+ $file{uses_todo}{$func}++;
+ }
+ }
+ }
+ }
+
+ while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
+ if (exists $need{$2}) {
+ $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
+ }
+ else { warning("Possibly wrong #define $1 in $filename") }
+ }
+
+ for (qw(uses needs uses_todo needed_global needed_static)) {
+ for $func (keys %{$file{$_}}) {
+ push @{$global{$_}{$func}}, $filename;
+ }
+ }
+
+ $files{$filename} = \%file;
+}
+
+# Globally resolve NEED_'s
+my $need;
+for $need (keys %{$global{needs}}) {
+ if (@{$global{needs}{$need}} > 1) {
+ my @targets = @{$global{needs}{$need}};
+ my @t = grep $files{$_}{needed_global}{$need}, @targets;
+ @targets = @t if @t;
+ @t = grep /\.xs$/i, @targets;
+ @targets = @t if @t;
+ my $target = shift @targets;
+ $files{$target}{needs}{$need} = 'global';
+ for (@{$global{needs}{$need}}) {
+ $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
+ }
+ }
+}
+
+for $filename (@files) {
+ exists $files{$filename} or next;
+
+ info("=== Analyzing $filename ===");
+
+ my %file = %{$files{$filename}};
+ my $func;
+ my $c = $file{code};
+ my $warnings = 0;
+
+ for $func (sort keys %{$file{uses_Perl}}) {
+ if ($API{$func}{varargs}) {
+ unless ($API{$func}{nothxarg}) {
+ my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
+ { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
+ if ($changes) {
+ warning("Doesn't pass interpreter argument aTHX to Perl_$func");
+ $file{changes} += $changes;
+ }
+ }
+ }
+ else {
+ warning("Uses Perl_$func instead of $func");
+ $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
+ {$func$1(}g);
+ }
+ }
+
+ for $func (sort keys %{$file{uses_replace}}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+
+ for $func (sort keys %{$file{uses_provided}}) {
+ if ($file{uses}{$func}) {
+ if (exists $file{uses_deps}{$func}) {
+ diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
+ }
+ else {
+ diag("Uses $func");
+ }
+ }
+ $warnings += hint($func);
+ }
+
+ unless ($opt{quiet}) {
+ for $func (sort keys %{$file{uses_todo}}) {
+ print "*** WARNING: Uses $func, which may not be portable below perl ",
+ format_version($API{$func}{todo}), ", even with '$ppport'\n";
+ $warnings++;
+ }
+ }
+
+ for $func (sort keys %{$file{needed_static}}) {
+ my $message = '';
+ if (not exists $file{uses}{$func}) {
+ $message = "No need to define NEED_$func if $func is never used";
+ }
+ elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
+ $message = "No need to define NEED_$func when already needed globally";
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
+ }
+ }
+
+ for $func (sort keys %{$file{needed_global}}) {
+ my $message = '';
+ if (not exists $global{uses}{$func}) {
+ $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
+ }
+ elsif (exists $file{needs}{$func}) {
+ if ($file{needs}{$func} eq 'extern') {
+ $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
+ }
+ elsif ($file{needs}{$func} eq 'static') {
+ $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
+ }
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
+ }
+ }
+
+ $file{needs_inc_ppport} = keys %{$file{uses}};
+
+ if ($file{needs_inc_ppport}) {
+ my $pp = '';
+
+ for $func (sort keys %{$file{needs}}) {
+ my $type = $file{needs}{$func};
+ next if $type eq 'extern';
+ my $suffix = $type eq 'global' ? '_GLOBAL' : '';
+ unless (exists $file{"needed_$type"}{$func}) {
+ if ($type eq 'global') {
+ diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
+ }
+ else {
+ diag("File needs $func, adding static request");
+ }
+ $pp .= "#define NEED_$func$suffix\n";
+ }
+ }
+
+ if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
+ $pp = '';
+ $file{changes}++;
+ }
+
+ unless ($file{has_inc_ppport}) {
+ diag("Needs to include '$ppport'");
+ $pp .= qq(#include "$ppport"\n)
+ }
+
+ if ($pp) {
+ $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
+ || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
+ || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
+ || ($c =~ s/^/$pp/);
+ }
+ }
+ else {
+ if ($file{has_inc_ppport}) {
+ diag("No need to include '$ppport'");
+ $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
+ }
+ }
+
+ # put back in our C comments
+ my $ix;
+ my $cppc = 0;
+ my @ccom = @{$file{ccom}};
+ for $ix (0 .. $#ccom) {
+ if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
+ $cppc++;
+ $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
+ }
+ else {
+ $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
+ }
+ }
+
+ if ($cppc) {
+ my $s = $cppc != 1 ? 's' : '';
+ warning("Uses $cppc C++ style comment$s, which is not portable");
+ }
+
+ my $s = $warnings != 1 ? 's' : '';
+ my $warn = $warnings ? " ($warnings warning$s)" : '';
+ info("Analysis completed$warn");
+
+ if ($file{changes}) {
+ if (exists $opt{copy}) {
+ my $newfile = "$filename$opt{copy}";
+ if (-e $newfile) {
+ error("'$newfile' already exists, refusing to write copy of '$filename'");
+ }
+ else {
+ local *F;
+ if (open F, ">$newfile") {
+ info("Writing copy of '$filename' with changes to '$newfile'");
+ print F $c;
+ close F;
+ }
+ else {
+ error("Cannot open '$newfile' for writing: $!");
+ }
+ }
+ }
+ elsif (exists $opt{patch} || $opt{changes}) {
+ if (exists $opt{patch}) {
+ unless ($patch_opened) {
+ if (open PATCH, ">$opt{patch}") {
+ $patch_opened = 1;
+ }
+ else {
+ error("Cannot open '$opt{patch}' for writing: $!");
+ delete $opt{patch};
+ $opt{changes} = 1;
+ goto fallback;
+ }
+ }
+ mydiff(\*PATCH, $filename, $c);
+ }
+ else {
+fallback:
+ info("Suggested changes:");
+ mydiff(\*STDOUT, $filename, $c);
+ }
+ }
+ else {
+ my $s = $file{changes} == 1 ? '' : 's';
+ info("$file{changes} potentially required change$s detected");
+ }
+ }
+ else {
+ info("Looks good");
+ }
+}
+
+close PATCH if $patch_opened;
+
+exit 0;
+
+
+sub try_use { eval "use @_;"; return $@ eq '' }
+
+sub mydiff
+{
+ local *F = shift;
+ my($file, $str) = @_;
+ my $diff;
+
+ if (exists $opt{diff}) {
+ $diff = run_diff($opt{diff}, $file, $str);
+ }
+
+ if (!defined $diff and try_use('Text::Diff')) {
+ $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
+ $diff = <<HEADER . $diff;
+--- $file
++++ $file.patched
+HEADER
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff -u', $file, $str);
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff', $file, $str);
+ }
+
+ if (!defined $diff) {
+ error("Cannot generate a diff. Please install Text::Diff or use --copy.");
+ return;
+ }
+
+ print F $diff;
+}
+
+sub run_diff
+{
+ my($prog, $file, $str) = @_;
+ my $tmp = 'dppptemp';
+ my $suf = 'aaa';
+ my $diff = '';
+ local *F;
+
+ while (-e "$tmp.$suf") { $suf++ }
+ $tmp = "$tmp.$suf";
+
+ if (open F, ">$tmp") {
+ print F $str;
+ close F;
+
+ if (open F, "$prog $file $tmp |") {
+ while (<F>) {
+ s/\Q$tmp\E/$file.patched/;
+ $diff .= $_;
+ }
+ close F;
+ unlink $tmp;
+ return $diff;
+ }
+
+ unlink $tmp;
+ }
+ else {
+ error("Cannot open '$tmp' for writing: $!");
+ }
+
+ return undef;
+}
+
+sub rec_depend
+{
+ my($func, $seen) = @_;
+ return () unless exists $depends{$func};
+ $seen = {%{$seen||{}}};
+ return () if $seen->{$func}++;
+ my %s;
+ grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
+}
+
+sub parse_version
+{
+ my $ver = shift;
+
+ if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ return ($1, $2, $3);
+ }
+ elsif ($ver !~ /^\d+\.[\d_]+$/) {
+ die "cannot parse version '$ver'\n";
+ }
+
+ $ver =~ s/_//g;
+ $ver =~ s/$/000000/;
+
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "cannot parse version '$ver'\n";
+ }
+ }
+
+ return ($r, $v, $s);
+}
+
+sub format_version
+{
+ my $ver = shift;
+
+ $ver =~ s/$/000000/;
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "invalid version '$ver'\n";
+ }
+ $s /= 10;
+
+ $ver = sprintf "%d.%03d", $r, $v;
+ $s > 0 and $ver .= sprintf "_%02d", $s;
+
+ return $ver;
+ }
+
+ return sprintf "%d.%d.%d", $r, $v, $s;
+}
+
+sub info
+{
+ $opt{quiet} and return;
+ print @_, "\n";
+}
+
+sub diag
+{
+ $opt{quiet} and return;
+ $opt{diag} and print @_, "\n";
+}
+
+sub warning
+{
+ $opt{quiet} and return;
+ print "*** ", @_, "\n";
+}
+
+sub error
+{
+ print "*** ERROR: ", @_, "\n";
+}
+
+my %given_hints;
+my %given_warnings;
+sub hint
+{
+ $opt{quiet} and return;
+ my $func = shift;
+ my $rv = 0;
+ if (exists $warnings{$func} && !$given_warnings{$func}++) {
+ my $warn = $warnings{$func};
+ $warn =~ s!^!*** !mg;
+ print "*** WARNING: $func\n", $warn;
+ $rv++;
+ }
+ if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
+ my $hint = $hints{$func};
+ $hint =~ s/^/ /mg;
+ print " --- hint for $func ---\n", $hint;
+ }
+ $rv;
+}
+
+sub usage
+{
+ my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
+ my %M = ( 'I' => '*' );
+ $usage =~ s/^\s*perl\s+\S+/$^X $0/;
+ $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
+
+ print <<ENDUSAGE;
+
+Usage: $usage
+
+See perldoc $0 for details.
+
+ENDUSAGE
+
+ exit 2;
+}
+
+sub strip
+{
+ my $self = do { local(@ARGV,$/)=($0); <> };
+ my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
+ $copy =~ s/^(?=\S+)/ /gms;
+ $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
+ $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
+if (\@ARGV && \$ARGV[0] eq '--unstrip') {
+ eval { require Devel::PPPort };
+ \$@ and die "Cannot require Devel::PPPort, please install.\\n";
+ if (eval \$Devel::PPPort::VERSION < $VERSION) {
+ die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
+ . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
+ . "Please install a newer version, or --unstrip will not work.\\n";
+ }
+ Devel::PPPort::WriteFile(\$0);
+ exit 0;
+}
+print <<END;
+
+Sorry, but this is a stripped version of \$0.
+
+To be able to use its original script and doc functionality,
+please try to regenerate this file using:
+
+ \$^X \$0 --unstrip
+
+END
+/ms;
+ my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
+ $c =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | ( "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' )
+ | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
+ $c =~ s!\s+$!!mg;
+ $c =~ s!^$LF!!mg;
+ $c =~ s!^\s*#\s*!#!mg;
+ $c =~ s!^\s+!!mg;
+
+ open OUT, ">$0" or die "cannot strip $0: $!\n";
+ print OUT "$pl$c\n";
+
+ exit 0;
+}
+
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef DPPP_NAMESPACE
+# define DPPP_NAMESPACE DPPP_
+#endif
+
+#define DPPP_CAT2(x,y) CAT2(x,y)
+#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
+
+#ifndef PERL_REVISION
+# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
+#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION))
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+#ifndef dTHX
+# define dTHX dNOOP
+#endif
+
+#ifndef dTHXa
+# define dTHXa(x) dNOOP
+#endif
+#ifndef pTHX
+# define pTHX void
+#endif
+
+#ifndef pTHX_
+# define pTHX_
+#endif
+
+#ifndef aTHX
+# define aTHX
+#endif
+
+#ifndef aTHX_
+# define aTHX_
+#endif
+
+#if (PERL_BCDVERSION < 0x5006000)
+# ifdef USE_THREADS
+# define aTHXR thr
+# define aTHXR_ thr,
+# else
+# define aTHXR
+# define aTHXR_
+# endif
+# define dTHXR dTHR
+#else
+# define aTHXR aTHX
+# define aTHXR_ aTHX_
+# define dTHXR dTHX
+#endif
+#ifndef dTHXoa
+# define dTHXoa(x) dTHXa(x)
+#endif
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifndef PERL_UCHAR_MIN
+# define PERL_UCHAR_MIN ((unsigned char)0)
+#endif
+
+#ifndef PERL_UCHAR_MAX
+# ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+# else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_USHORT_MIN
+# define PERL_USHORT_MIN ((unsigned short)0)
+#endif
+
+#ifndef PERL_USHORT_MAX
+# ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+# else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MAX
+# ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+# else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MIN
+# ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+# else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MAX
+# ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+# else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MIN
+# define PERL_UINT_MIN ((unsigned int)0)
+#endif
+
+#ifndef PERL_INT_MAX
+# ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+# else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_INT_MIN
+# ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+# else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MAX
+# ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+# else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MIN
+# define PERL_ULONG_MIN ((unsigned long)0L)
+#endif
+
+#ifndef PERL_LONG_MAX
+# ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+# else
+# ifdef MAXLONG
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_LONG_MIN
+# ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+# else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
+# ifndef PERL_UQUAD_MAX
+# ifdef ULONGLONG_MAX
+# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
+# else
+# ifdef MAXULONGLONG
+# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
+# else
+# define PERL_UQUAD_MAX (~(unsigned long long)0)
+# endif
+# endif
+# endif
+
+# ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN ((unsigned long long)0L)
+# endif
+
+# ifndef PERL_QUAD_MAX
+# ifdef LONGLONG_MAX
+# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
+# else
+# ifdef MAXLONGLONG
+# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
+# else
+# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
+# endif
+# endif
+# endif
+
+# ifndef PERL_QUAD_MIN
+# ifdef LONGLONG_MIN
+# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
+# else
+# ifdef MINLONGLONG
+# define PERL_QUAD_MIN ((long long)MINLONGLONG)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+/* This is based on code from 5.003 perl.h */
+#ifdef HAS_QUAD
+# ifdef cray
+#ifndef IVTYPE
+# define IVTYPE int
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_INT_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_INT_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UINT_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UINT_MAX
+#endif
+
+# ifdef INTSIZE
+#ifndef IVSIZE
+# define IVSIZE INTSIZE
+#endif
+
+# endif
+# else
+# if defined(convex) || defined(uts)
+#ifndef IVTYPE
+# define IVTYPE long long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_QUAD_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_QUAD_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UQUAD_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UQUAD_MAX
+#endif
+
+# ifdef LONGLONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGLONGSIZE
+#endif
+
+# endif
+# else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+# ifdef LONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGSIZE
+#endif
+
+# endif
+# endif
+# endif
+#ifndef IVSIZE
+# define IVSIZE 8
+#endif
+
+#ifndef PERL_QUAD_MIN
+# define PERL_QUAD_MIN IV_MIN
+#endif
+
+#ifndef PERL_QUAD_MAX
+# define PERL_QUAD_MAX IV_MAX
+#endif
+
+#ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN UV_MIN
+#endif
+
+#ifndef PERL_UQUAD_MAX
+# define PERL_UQUAD_MAX UV_MAX
+#endif
+
+#else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+#endif
+
+#ifndef IVSIZE
+# ifdef LONGSIZE
+# define IVSIZE LONGSIZE
+# else
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+# endif
+#endif
+#ifndef UVTYPE
+# define UVTYPE unsigned IVTYPE
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+#ifndef sv_setuv
+# define sv_setuv(sv, uv) \
+ STMT_START { \
+ UV TeMpUv = uv; \
+ if (TeMpUv <= IV_MAX) \
+ sv_setiv(sv, TeMpUv); \
+ else \
+ sv_setnv(sv, (double)TeMpUv); \
+ } STMT_END
+#endif
+#ifndef newSVuv
+# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
+#endif
+#ifndef sv_2uv
+# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
+#endif
+
+#ifndef SvUVX
+# define SvUVX(sv) ((UV)SvIVX(sv))
+#endif
+
+#ifndef SvUVXx
+# define SvUVXx(sv) SvUVX(sv)
+#endif
+
+#ifndef SvUV
+# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+#endif
+
+#ifndef SvUVx
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+#endif
+
+/* Hint: sv_uv
+ * Always use the SvUVx() macro instead of sv_uv().
+ */
+#ifndef sv_uv
+# define sv_uv(sv) SvUVx(sv)
+#endif
+
+#if !defined(SvUOK) && defined(SvIOK_UV)
+# define SvUOK(sv) SvIOK_UV(sv)
+#endif
+#ifndef XST_mUV
+# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
+#endif
+
+#ifndef XSRETURN_UV
+# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
+#endif
+#ifndef PUSHu
+# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+#endif
+
+#ifndef XPUSHu
+# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+#endif
+
+#ifdef HAS_MEMCMP
+#ifndef memNE
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#endif
+
+#else
+#ifndef memNE
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#endif
+#ifndef MoveD
+# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifndef CopyD
+# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifdef HAS_MEMSET
+#ifndef ZeroD
+# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
+#endif
+
+#else
+#ifndef ZeroD
+# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
+#endif
+
+#endif
+#ifndef PoisonWith
+# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
+#endif
+
+#ifndef PoisonNew
+# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
+#endif
+
+#ifndef PoisonFree
+# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
+#endif
+
+#ifndef Poison
+# define Poison(d,n,t) PoisonFree(d,n,t)
+#endif
+#ifndef Newx
+# define Newx(v,n,t) New(0,v,n,t)
+#endif
+
+#ifndef Newxc
+# define Newxc(v,n,t,c) Newc(0,v,n,t,c)
+#endif
+
+#ifndef Newxz
+# define Newxz(v,n,t) Newz(0,v,n,t)
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+#ifndef PERL_UNUSED_ARG
+# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# include <note.h>
+# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
+# else
+# define PERL_UNUSED_ARG(x) ((void)x)
+# endif
+#endif
+
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif
+
+#ifndef PERL_UNUSED_CONTEXT
+# ifdef USE_ITHREADS
+# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
+# else
+# define PERL_UNUSED_CONTEXT
+# endif
+#endif
+#ifndef NOOP
+# define NOOP /*EMPTY*/(void)0
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+# else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+# endif
+#endif
+
+#ifndef PTR2ul
+# if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+# endif
+#endif
+#ifndef PTR2nat
+# define PTR2nat(p) (PTRV)(p)
+#endif
+
+#ifndef NUM2PTR
+# define NUM2PTR(any,d) (any)PTR2nat(d)
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(p) INT2PTR(IV,p)
+#endif
+
+#ifndef PTR2UV
+# define PTR2UV(p) INT2PTR(UV,p)
+#endif
+
+#ifndef PTR2NV
+# define PTR2NV(p) NUM2PTR(NV,p)
+#endif
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#if defined(PERL_GCC_PEDANTIC)
+# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# ifndef PERL_USE_GCC_BRACE_GROUPS
+# define PERL_USE_GCC_BRACE_GROUPS
+# endif
+#endif
+
+#undef STMT_START
+#undef STMT_END
+#ifdef PERL_USE_GCC_BRACE_GROUPS
+# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
+# define STMT_END )
+#else
+# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+#endif
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef DEFSV_set
+# define DEFSV_set(sv) (DEFSV = (sv))
+#endif
+
+/* Older perls (<=5.003) lack AvFILLp */
+#ifndef AvFILLp
+# define AvFILLp AvFILL
+#endif
+#ifndef ERRSV
+# define ERRSV get_sv("@",FALSE)
+#endif
+
+/* Hint: gv_stashpvn
+ * This function's backport doesn't support the length parameter, but
+ * rather ignores it. Portability can only be ensured if the length
+ * parameter is used for speed reasons, but the length can always be
+ * correctly computed from the string argument.
+ */
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
+#endif
+
+/* Replace: 1 */
+#ifndef get_cv
+# define get_cv perl_get_cv
+#endif
+
+#ifndef get_sv
+# define get_sv perl_get_sv
+#endif
+
+#ifndef get_av
+# define get_av perl_get_av
+#endif
+
+#ifndef get_hv
+# define get_hv perl_get_hv
+#endif
+
+/* Replace: 0 */
+#ifndef dUNDERBAR
+# define dUNDERBAR dNOOP
+#endif
+
+#ifndef UNDERBAR
+# define UNDERBAR DEFSV
+#endif
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+#ifndef dXSTARG
+# define dXSTARG SV * targ = sv_newmortal()
+#endif
+#ifndef dAXMARK
+# define dAXMARK I32 ax = POPMARK; \
+ register SV ** const mark = PL_stack_base + ax++
+#endif
+#ifndef XSprePUSH
+# define XSprePUSH (sp = PL_stack_base + ax - 1)
+#endif
+
+#if (PERL_BCDVERSION < 0x5005000)
+# undef XSRETURN
+# define XSRETURN(off) \
+ STMT_START { \
+ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
+ return; \
+ } STMT_END
+#endif
+#ifndef XSPROTO
+# define XSPROTO(name) void name(pTHX_ CV* cv)
+#endif
+
+#ifndef SVfARG
+# define SVfARG(p) ((void*)(p))
+#endif
+#ifndef PERL_ABS
+# define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
+#endif
+#ifndef dVAR
+# define dVAR dNOOP
+#endif
+#ifndef SVf
+# define SVf "_"
+#endif
+#ifndef UTF8_MAXBYTES
+# define UTF8_MAXBYTES UTF8_MAXLEN
+#endif
+#ifndef CPERLscope
+# define CPERLscope(x) x
+#endif
+#ifndef PERL_HASH
+# define PERL_HASH(hash,str,len) \
+ STMT_START { \
+ const char *s_PeRlHaSh = str; \
+ I32 i_PeRlHaSh = len; \
+ U32 hash_PeRlHaSh = 0; \
+ while (i_PeRlHaSh--) \
+ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
+ (hash) = hash_PeRlHaSh; \
+ } STMT_END
+#endif
+
+#ifndef PERLIO_FUNCS_DECL
+# ifdef PERLIO_FUNCS_CONST
+# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
+# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
+# else
+# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
+# define PERLIO_FUNCS_CAST(funcs) (funcs)
+# endif
+#endif
+
+/* provide these typedefs for older perls */
+#if (PERL_BCDVERSION < 0x5009003)
+
+# ifdef ARGSproto
+typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
+# else
+typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
+# endif
+
+typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
+
+#endif
+#ifndef isPSXSPC
+# define isPSXSPC(c) (isSPACE(c) || (c) == '\v')
+#endif
+
+#ifndef isBLANK
+# define isBLANK(c) ((c) == ' ' || (c) == '\t')
+#endif
+
+#ifdef EBCDIC
+#ifndef isALNUMC
+# define isALNUMC(c) isalnum(c)
+#endif
+
+#ifndef isASCII
+# define isASCII(c) isascii(c)
+#endif
+
+#ifndef isCNTRL
+# define isCNTRL(c) iscntrl(c)
+#endif
+
+#ifndef isGRAPH
+# define isGRAPH(c) isgraph(c)
+#endif
+
+#ifndef isPRINT
+# define isPRINT(c) isprint(c)
+#endif
+
+#ifndef isPUNCT
+# define isPUNCT(c) ispunct(c)
+#endif
+
+#ifndef isXDIGIT
+# define isXDIGIT(c) isxdigit(c)
+#endif
+
+#else
+# if (PERL_BCDVERSION < 0x5010000)
+/* Hint: isPRINT
+ * The implementation in older perl versions includes all of the
+ * isSPACE() characters, which is wrong. The version provided by
+ * Devel::PPPort always overrides a present buggy version.
+ */
+# undef isPRINT
+# endif
+#ifndef isALNUMC
+# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
+#endif
+
+#ifndef isASCII
+# define isASCII(c) ((c) <= 127)
+#endif
+
+#ifndef isCNTRL
+# define isCNTRL(c) ((c) < ' ' || (c) == 127)
+#endif
+
+#ifndef isGRAPH
+# define isGRAPH(c) (isALNUM(c) || isPUNCT(c))
+#endif
+
+#ifndef isPRINT
+# define isPRINT(c) (((c) >= 32 && (c) < 127))
+#endif
+
+#ifndef isPUNCT
+# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
+#endif
+
+#ifndef isXDIGIT
+# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
+#endif
+
+#endif
+
+#ifndef PERL_SIGNALS_UNSAFE_FLAG
+
+#define PERL_SIGNALS_UNSAFE_FLAG 0x0001
+
+#if (PERL_BCDVERSION < 0x5008000)
+# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG
+#else
+# define D_PPP_PERL_SIGNALS_INIT 0
+#endif
+
+#if defined(NEED_PL_signals)
+static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
+#elif defined(NEED_PL_signals_GLOBAL)
+U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
+#else
+extern U32 DPPP_(my_PL_signals);
+#endif
+#define PL_signals DPPP_(my_PL_signals)
+
+#endif
+
+/* Hint: PL_ppaddr
+ * Calling an op via PL_ppaddr requires passing a context argument
+ * for threaded builds. Since the context argument is different for
+ * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will
+ * automatically be defined as the correct argument.
+ */
+
+#if (PERL_BCDVERSION <= 0x5005005)
+/* Replace: 1 */
+# define PL_ppaddr ppaddr
+# define PL_no_modify no_modify
+/* Replace: 0 */
+#endif
+
+#if (PERL_BCDVERSION <= 0x5004005)
+/* Replace: 1 */
+# define PL_DBsignal DBsignal
+# define PL_DBsingle DBsingle
+# define PL_DBsub DBsub
+# define PL_DBtrace DBtrace
+# define PL_Sv Sv
+# define PL_bufend bufend
+# define PL_bufptr bufptr
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_debstash debstash
+# define PL_defgv defgv
+# define PL_diehook diehook
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_errgv errgv
+# define PL_error_count error_count
+# define PL_expect expect
+# define PL_hexdigit hexdigit
+# define PL_hints hints
+# define PL_in_my in_my
+# define PL_laststatval laststatval
+# define PL_lex_state lex_state
+# define PL_lex_stuff lex_stuff
+# define PL_linestr linestr
+# define PL_na na
+# define PL_perl_destruct_level perl_destruct_level
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stack_base stack_base
+# define PL_stack_sp stack_sp
+# define PL_statcache statcache
+# define PL_stdingv stdingv
+# define PL_sv_arenaroot sv_arenaroot
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+# define PL_tainted tainted
+# define PL_tainting tainting
+# define PL_tokenbuf tokenbuf
+/* Replace: 0 */
+#endif
+
+/* Warning: PL_parser
+ * For perl versions earlier than 5.9.5, this is an always
+ * non-NULL dummy. Also, it cannot be dereferenced. Don't
+ * use it if you can avoid is and unless you absolutely know
+ * what you're doing.
+ * If you always check that PL_parser is non-NULL, you can
+ * define DPPP_PL_parser_NO_DUMMY to avoid the creation of
+ * a dummy parser structure.
+ */
+
+#if (PERL_BCDVERSION >= 0x5009005)
+# ifdef DPPP_PL_parser_NO_DUMMY
+# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
+ (croak("panic: PL_parser == NULL in %s:%d", \
+ __FILE__, __LINE__), (yy_parser *) NULL))->var)
+# else
+# ifdef DPPP_PL_parser_NO_DUMMY_WARNING
+# define D_PPP_parser_dummy_warning(var)
+# else
+# define D_PPP_parser_dummy_warning(var) \
+ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
+# endif
+# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
+ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
+#if defined(NEED_PL_parser)
+static yy_parser DPPP_(dummy_PL_parser);
+#elif defined(NEED_PL_parser_GLOBAL)
+yy_parser DPPP_(dummy_PL_parser);
+#else
+extern yy_parser DPPP_(dummy_PL_parser);
+#endif
+
+# endif
+
+/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */
+/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf
+ * Do not use this variable unless you know exactly what you're
+ * doint. It is internal to the perl parser and may change or even
+ * be removed in the future. As of perl 5.9.5, you have to check
+ * for (PL_parser != NULL) for this variable to have any effect.
+ * An always non-NULL PL_parser dummy is provided for earlier
+ * perl versions.
+ * If PL_parser is NULL when you try to access this variable, a
+ * dummy is being accessed instead and a warning is issued unless
+ * you define DPPP_PL_parser_NO_DUMMY_WARNING.
+ * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access
+ * this variable will croak with a panic message.
+ */
+
+# define PL_expect D_PPP_my_PL_parser_var(expect)
+# define PL_copline D_PPP_my_PL_parser_var(copline)
+# define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
+# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
+# define PL_linestr D_PPP_my_PL_parser_var(linestr)
+# define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
+# define PL_bufend D_PPP_my_PL_parser_var(bufend)
+# define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
+# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
+# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
+# define PL_in_my D_PPP_my_PL_parser_var(in_my)
+# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
+# define PL_error_count D_PPP_my_PL_parser_var(error_count)
+
+
+#else
+
+/* ensure that PL_parser != NULL and cannot be dereferenced */
+# define PL_parser ((void *) 1)
+
+#endif
+#ifndef mPUSHs
+# define mPUSHs(s) PUSHs(sv_2mortal(s))
+#endif
+
+#ifndef PUSHmortal
+# define PUSHmortal PUSHs(sv_newmortal())
+#endif
+
+#ifndef mPUSHp
+# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l))
+#endif
+
+#ifndef mPUSHn
+# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n))
+#endif
+
+#ifndef mPUSHi
+# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i))
+#endif
+
+#ifndef mPUSHu
+# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u))
+#endif
+#ifndef mXPUSHs
+# define mXPUSHs(s) XPUSHs(sv_2mortal(s))
+#endif
+
+#ifndef XPUSHmortal
+# define XPUSHmortal XPUSHs(sv_newmortal())
+#endif
+
+#ifndef mXPUSHp
+# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END
+#endif
+
+#ifndef mXPUSHn
+# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END
+#endif
+
+#ifndef mXPUSHi
+# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END
+#endif
+
+#ifndef mXPUSHu
+# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END
+#endif
+
+/* Replace: 1 */
+#ifndef call_sv
+# define call_sv perl_call_sv
+#endif
+
+#ifndef call_pv
+# define call_pv perl_call_pv
+#endif
+
+#ifndef call_argv
+# define call_argv perl_call_argv
+#endif
+
+#ifndef call_method
+# define call_method perl_call_method
+#endif
+#ifndef eval_sv
+# define eval_sv perl_eval_sv
+#endif
+
+/* Replace: 0 */
+#ifndef PERL_LOADMOD_DENY
+# define PERL_LOADMOD_DENY 0x1
+#endif
+
+#ifndef PERL_LOADMOD_NOIMPORT
+# define PERL_LOADMOD_NOIMPORT 0x2
+#endif
+
+#ifndef PERL_LOADMOD_IMPORT_OPS
+# define PERL_LOADMOD_IMPORT_OPS 0x4
+#endif
+
+#ifndef G_METHOD
+# define G_METHOD 64
+# ifdef call_sv
+# undef call_sv
+# endif
+# if (PERL_BCDVERSION < 0x5006000)
+# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
+ (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
+# else
+# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
+ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
+# endif
+#endif
+
+/* Replace perl_eval_pv with eval_pv */
+
+#ifndef eval_pv
+#if defined(NEED_eval_pv)
+static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+static
+#else
+extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+#endif
+
+#ifdef eval_pv
+# undef eval_pv
+#endif
+#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
+#define Perl_eval_pv DPPP_(my_eval_pv)
+
+#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
+
+SV*
+DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
+{
+ dSP;
+ SV* sv = newSVpv(p, 0);
+
+ PUSHMARK(sp);
+ eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+
+ SPAGAIN;
+ sv = POPs;
+ PUTBACK;
+
+ if (croak_on_error && SvTRUE(GvSV(errgv)))
+ croak(SvPVx(GvSV(errgv), na));
+
+ return sv;
+}
+
+#endif
+#endif
+
+#ifndef vload_module
+#if defined(NEED_vload_module)
+static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args);
+static
+#else
+extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args);
+#endif
+
+#ifdef vload_module
+# undef vload_module
+#endif
+#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d)
+#define Perl_vload_module DPPP_(my_vload_module)
+
+#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
+
+void
+DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args)
+{
+ dTHR;
+ dVAR;
+ OP *veop, *imop;
+
+ OP * const modname = newSVOP(OP_CONST, 0, name);
+ /* 5.005 has a somewhat hacky force_normal that doesn't croak on
+ SvREADONLY() if PL_compling is true. Current perls take care in
+ ck_require() to correctly turn off SvREADONLY before calling
+ force_normal_flags(). This seems a better fix than fudging PL_compling
+ */
+ SvREADONLY_off(((SVOP*)modname)->op_sv);
+ modname->op_private |= OPpCONST_BARE;
+ if (ver) {
+ veop = newSVOP(OP_CONST, 0, ver);
+ }
+ else
+ veop = NULL;
+ if (flags & PERL_LOADMOD_NOIMPORT) {
+ imop = sawparens(newNULLLIST());
+ }
+ else if (flags & PERL_LOADMOD_IMPORT_OPS) {
+ imop = va_arg(*args, OP*);
+ }
+ else {
+ SV *sv;
+ imop = NULL;
+ sv = va_arg(*args, SV*);
+ while (sv) {
+ imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
+ sv = va_arg(*args, SV*);
+ }
+ }
+ {
+ const line_t ocopline = PL_copline;
+ COP * const ocurcop = PL_curcop;
+ const int oexpect = PL_expect;
+
+#if (PERL_BCDVERSION >= 0x5004000)
+ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ veop, modname, imop);
+#else
+ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
+ modname, imop);
+#endif
+ PL_expect = oexpect;
+ PL_copline = ocopline;
+ PL_curcop = ocurcop;
+ }
+}
+
+#endif
+#endif
+
+#ifndef load_module
+#if defined(NEED_load_module)
+static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...);
+static
+#else
+extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...);
+#endif
+
+#ifdef load_module
+# undef load_module
+#endif
+#define load_module DPPP_(my_load_module)
+#define Perl_load_module DPPP_(my_load_module)
+
+#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
+
+void
+DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
+{
+ va_list args;
+ va_start(args, ver);
+ vload_module(flags, name, ver, &args);
+ va_end(args);
+}
+
+#endif
+#endif
+#ifndef newRV_inc
+# define newRV_inc(sv) newRV(sv) /* Replace */
+#endif
+
+#ifndef newRV_noinc
+#if defined(NEED_newRV_noinc)
+static SV * DPPP_(my_newRV_noinc)(SV *sv);
+static
+#else
+extern SV * DPPP_(my_newRV_noinc)(SV *sv);
+#endif
+
+#ifdef newRV_noinc
+# undef newRV_noinc
+#endif
+#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
+#define Perl_newRV_noinc DPPP_(my_newRV_noinc)
+
+#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
+SV *
+DPPP_(my_newRV_noinc)(SV *sv)
+{
+ SV *rv = (SV *)newRV(sv);
+ SvREFCNT_dec(sv);
+ return rv;
+}
+#endif
+#endif
+
+/* Hint: newCONSTSUB
+ * Returns a CV* as of perl-5.7.1. This return value is not supported
+ * by Devel::PPPort.
+ */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
+#if defined(NEED_newCONSTSUB)
+static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
+static
+#else
+extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
+#endif
+
+#ifdef newCONSTSUB
+# undef newCONSTSUB
+#endif
+#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
+#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+
+/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */
+/* (There's no PL_parser in perl < 5.005, so this is completely safe) */
+#define D_PPP_PL_copline PL_copline
+
+void
+DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv)
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = D_PPP_PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_BCDVERSION < 0x5003022)
+ start_subparse(),
+#elif (PERL_BCDVERSION == 0x5003022)
+ start_subparse(0),
+#else /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+#endif
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+#ifndef START_MY_CXT
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_BCDVERSION < 0x5004068)
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+#endif
+
+#else /* single interpreter */
+
+#ifndef START_MY_CXT
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+#define MY_CXT_CLONE NOOP
+#endif
+
+#endif
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
+ /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef SvREFCNT_inc
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define SvREFCNT_inc(sv) \
+ ({ \
+ SV * const _sv = (SV*)(sv); \
+ if (_sv) \
+ (SvREFCNT(_sv))++; \
+ _sv; \
+ })
+# else
+# define SvREFCNT_inc(sv) \
+ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
+# endif
+#endif
+
+#ifndef SvREFCNT_inc_simple
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define SvREFCNT_inc_simple(sv) \
+ ({ \
+ if (sv) \
+ (SvREFCNT(sv))++; \
+ (SV *)(sv); \
+ })
+# else
+# define SvREFCNT_inc_simple(sv) \
+ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL)
+# endif
+#endif
+
+#ifndef SvREFCNT_inc_NN
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define SvREFCNT_inc_NN(sv) \
+ ({ \
+ SV * const _sv = (SV*)(sv); \
+ SvREFCNT(_sv)++; \
+ _sv; \
+ })
+# else
+# define SvREFCNT_inc_NN(sv) \
+ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
+# endif
+#endif
+
+#ifndef SvREFCNT_inc_void
+# ifdef PERL_USE_GCC_BRACE_GROUPS
+# define SvREFCNT_inc_void(sv) \
+ ({ \
+ SV * const _sv = (SV*)(sv); \
+ if (_sv) \
+ (void)(SvREFCNT(_sv)++); \
+ })
+# else
+# define SvREFCNT_inc_void(sv) \
+ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
+# endif
+#endif
+#ifndef SvREFCNT_inc_simple_void
+# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
+#endif
+
+#ifndef SvREFCNT_inc_simple_NN
+# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
+#endif
+
+#ifndef SvREFCNT_inc_void_NN
+# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
+#endif
+
+#ifndef SvREFCNT_inc_simple_void_NN
+# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
+#endif
+
+#ifndef newSV_type
+
+#if defined(NEED_newSV_type)
+static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
+static
+#else
+extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
+#endif
+
+#ifdef newSV_type
+# undef newSV_type
+#endif
+#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a)
+#define Perl_newSV_type DPPP_(my_newSV_type)
+
+#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL)
+
+SV*
+DPPP_(my_newSV_type)(pTHX_ svtype const t)
+{
+ SV* const sv = newSV(0);
+ sv_upgrade(sv, t);
+ return sv;
+}
+
+#endif
+
+#endif
+
+#if (PERL_BCDVERSION < 0x5006000)
+# define D_PPP_CONSTPV_ARG(x) ((char *) (x))
+#else
+# define D_PPP_CONSTPV_ARG(x) (x)
+#endif
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((data) \
+ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
+ : newSV(0))
+#endif
+#ifndef newSVpvn_utf8
+# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+#endif
+#ifndef SVf_UTF8
+# define SVf_UTF8 0
+#endif
+
+#ifndef newSVpvn_flags
+
+#if defined(NEED_newSVpvn_flags)
+static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags);
+static
+#else
+extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags);
+#endif
+
+#ifdef newSVpvn_flags
+# undef newSVpvn_flags
+#endif
+#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c)
+#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags)
+
+#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL)
+
+SV *
+DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags)
+{
+ SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len);
+ SvFLAGS(sv) |= (flags & SVf_UTF8);
+ return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
+}
+
+#endif
+
+#endif
+
+/* Backwards compatibility stuff... :-( */
+#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen)
+# define NEED_sv_2pv_flags
+#endif
+#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL)
+# define NEED_sv_2pv_flags_GLOBAL
+#endif
+
+/* Hint: sv_2pv_nolen
+ * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen().
+ */
+#ifndef sv_2pv_nolen
+# define sv_2pv_nolen(sv) SvPV_nolen(sv)
+#endif
+
+#ifdef SvPVbyte
+
+/* Hint: SvPVbyte
+ * Does not work in perl-5.6.1, ppport.h implements a version
+ * borrowed from perl-5.7.3.
+ */
+
+#if (PERL_BCDVERSION < 0x5007000)
+
+#if defined(NEED_sv_2pvbyte)
+static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
+static
+#else
+extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
+#endif
+
+#ifdef sv_2pvbyte
+# undef sv_2pvbyte
+#endif
+#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
+#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
+
+#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
+
+char *
+DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp)
+{
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+}
+
+#endif
+
+/* Hint: sv_2pvbyte
+ * Use the SvPVbyte() macro instead of sv_2pvbyte().
+ */
+
+#undef SvPVbyte
+
+#define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+
+#endif
+
+#else
+
+# define SvPVbyte SvPV
+# define sv_2pvbyte sv_2pv
+
+#endif
+#ifndef sv_2pvbyte_nolen
+# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv)
+#endif
+
+/* Hint: sv_pvn
+ * Always use the SvPV() macro instead of sv_pvn().
+ */
+
+/* Hint: sv_pvn_force
+ * Always use the SvPV_force() macro instead of sv_pvn_force().
+ */
+
+/* If these are undefined, they're not handled by the core anyway */
+#ifndef SV_IMMEDIATE_UNREF
+# define SV_IMMEDIATE_UNREF 0
+#endif
+
+#ifndef SV_GMAGIC
+# define SV_GMAGIC 0
+#endif
+
+#ifndef SV_COW_DROP_PV
+# define SV_COW_DROP_PV 0
+#endif
+
+#ifndef SV_UTF8_NO_ENCODING
+# define SV_UTF8_NO_ENCODING 0
+#endif
+
+#ifndef SV_NOSTEAL
+# define SV_NOSTEAL 0
+#endif
+
+#ifndef SV_CONST_RETURN
+# define SV_CONST_RETURN 0
+#endif
+
+#ifndef SV_MUTABLE_RETURN
+# define SV_MUTABLE_RETURN 0
+#endif
+
+#ifndef SV_SMAGIC
+# define SV_SMAGIC 0
+#endif
+
+#ifndef SV_HAS_TRAILING_NUL
+# define SV_HAS_TRAILING_NUL 0
+#endif
+
+#ifndef SV_COW_SHARED_HASH_KEYS
+# define SV_COW_SHARED_HASH_KEYS 0
+#endif
+
+#if (PERL_BCDVERSION < 0x5007002)
+
+#if defined(NEED_sv_2pv_flags)
+static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
+static
+#else
+extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
+#endif
+
+#ifdef sv_2pv_flags
+# undef sv_2pv_flags
+#endif
+#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c)
+#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags)
+
+#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL)
+
+char *
+DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+{
+ STRLEN n_a = (STRLEN) flags;
+ return sv_2pv(sv, lp ? lp : &n_a);
+}
+
+#endif
+
+#if defined(NEED_sv_pvn_force_flags)
+static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
+static
+#else
+extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
+#endif
+
+#ifdef sv_pvn_force_flags
+# undef sv_pvn_force_flags
+#endif
+#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c)
+#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags)
+
+#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL)
+
+char *
+DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+{
+ STRLEN n_a = (STRLEN) flags;
+ return sv_pvn_force(sv, lp ? lp : &n_a);
+}
+
+#endif
+
+#endif
+
+#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) )
+# define DPPP_SVPV_NOLEN_LP_ARG &PL_na
+#else
+# define DPPP_SVPV_NOLEN_LP_ARG 0
+#endif
+#ifndef SvPV_const
+# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
+#endif
+
+#ifndef SvPV_mutable
+# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
+#endif
+#ifndef SvPV_flags
+# define SvPV_flags(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
+#endif
+#ifndef SvPV_flags_const
+# define SvPV_flags_const(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
+ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
+#endif
+#ifndef SvPV_flags_const_nolen
+# define SvPV_flags_const_nolen(sv, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX_const(sv) : \
+ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN))
+#endif
+#ifndef SvPV_flags_mutable
+# define SvPV_flags_mutable(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
+ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
+#endif
+#ifndef SvPV_force
+# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
+#endif
+
+#ifndef SvPV_force_nolen
+# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
+#endif
+
+#ifndef SvPV_force_mutable
+# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC)
+#endif
+
+#ifndef SvPV_force_nomg
+# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
+#endif
+
+#ifndef SvPV_force_nomg_nolen
+# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
+#endif
+#ifndef SvPV_force_flags
+# define SvPV_force_flags(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+#endif
+#ifndef SvPV_force_flags_nolen
+# define SvPV_force_flags_nolen(sv, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags))
+#endif
+#ifndef SvPV_force_flags_mutable
+# define SvPV_force_flags_mutable(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
+ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
+#endif
+#ifndef SvPV_nolen
+# define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC))
+#endif
+#ifndef SvPV_nolen_const
+# define SvPV_nolen_const(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN))
+#endif
+#ifndef SvPV_nomg
+# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
+#endif
+
+#ifndef SvPV_nomg_const
+# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
+#endif
+
+#ifndef SvPV_nomg_const_nolen
+# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
+#endif
+#ifndef SvPV_renew
+# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \
+ SvPV_set((sv), (char *) saferealloc( \
+ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \
+ } STMT_END
+#endif
+#ifndef SvMAGIC_set
+# define SvMAGIC_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
+ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
+#endif
+
+#if (PERL_BCDVERSION < 0x5009003)
+#ifndef SvPVX_const
+# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
+#endif
+
+#ifndef SvPVX_mutable
+# define SvPVX_mutable(sv) (0 + SvPVX(sv))
+#endif
+#ifndef SvRV_set
+# define SvRV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
+ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
+#endif
+
+#else
+#ifndef SvPVX_const
+# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
+#endif
+
+#ifndef SvPVX_mutable
+# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
+#endif
+#ifndef SvRV_set
+# define SvRV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
+ ((sv)->sv_u.svu_rv = (val)); } STMT_END
+#endif
+
+#endif
+#ifndef SvSTASH_set
+# define SvSTASH_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
+ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
+#endif
+
+#if (PERL_BCDVERSION < 0x5004000)
+#ifndef SvUV_set
+# define SvUV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
+#endif
+
+#else
+#ifndef SvUV_set
+# define SvUV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
+#endif
+
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf)
+#if defined(NEED_vnewSVpvf)
+static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
+static
+#else
+extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
+#endif
+
+#ifdef vnewSVpvf
+# undef vnewSVpvf
+#endif
+#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
+#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
+
+#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
+
+SV *
+DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
+{
+ register SV *sv = newSV(0);
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ return sv;
+}
+
+#endif
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf)
+# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf)
+# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg)
+#if defined(NEED_sv_catpvf_mg)
+static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
+#endif
+
+#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
+
+#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
+#if defined(NEED_sv_catpvf_mg_nocontext)
+static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...);
+#endif
+
+#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+
+#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
+#ifndef sv_catpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
+# else
+# define sv_catpvf_mg Perl_sv_catpvf_mg
+# endif
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg)
+# define sv_vcatpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg)
+#if defined(NEED_sv_setpvf_mg)
+static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
+#endif
+
+#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
+
+#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
+#if defined(NEED_sv_setpvf_mg_nocontext)
+static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...);
+#endif
+
+#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+
+#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
+#ifndef sv_setpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
+# else
+# define sv_setpvf_mg Perl_sv_setpvf_mg
+# endif
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg)
+# define sv_vsetpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+
+#ifndef newSVpvn_share
+
+#if defined(NEED_newSVpvn_share)
+static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
+static
+#else
+extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
+#endif
+
+#ifdef newSVpvn_share
+# undef newSVpvn_share
+#endif
+#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
+#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
+
+#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
+
+SV *
+DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash)
+{
+ SV *sv;
+ if (len < 0)
+ len = -len;
+ if (!hash)
+ PERL_HASH(hash, (char*) src, len);
+ sv = newSVpvn((char *) src, len);
+ sv_upgrade(sv, SVt_PVIV);
+ SvIVX(sv) = hash;
+ SvREADONLY_on(sv);
+ SvPOK_on(sv);
+ return sv;
+}
+
+#endif
+
+#endif
+#ifndef SvSHARED_HASH
+# define SvSHARED_HASH(sv) (0 + SvUVX(sv))
+#endif
+#ifndef HvNAME_get
+# define HvNAME_get(hv) HvNAME(hv)
+#endif
+#ifndef HvNAMELEN_get
+# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
+#endif
+#ifndef GvSVn
+# define GvSVn(gv) GvSV(gv)
+#endif
+
+#ifndef isGV_with_GP
+# define isGV_with_GP(gv) isGV(gv)
+#endif
+#ifndef WARN_ALL
+# define WARN_ALL 0
+#endif
+
+#ifndef WARN_CLOSURE
+# define WARN_CLOSURE 1
+#endif
+
+#ifndef WARN_DEPRECATED
+# define WARN_DEPRECATED 2
+#endif
+
+#ifndef WARN_EXITING
+# define WARN_EXITING 3
+#endif
+
+#ifndef WARN_GLOB
+# define WARN_GLOB 4
+#endif
+
+#ifndef WARN_IO
+# define WARN_IO 5
+#endif
+
+#ifndef WARN_CLOSED
+# define WARN_CLOSED 6
+#endif
+
+#ifndef WARN_EXEC
+# define WARN_EXEC 7
+#endif
+
+#ifndef WARN_LAYER
+# define WARN_LAYER 8
+#endif
+
+#ifndef WARN_NEWLINE
+# define WARN_NEWLINE 9
+#endif
+
+#ifndef WARN_PIPE
+# define WARN_PIPE 10
+#endif
+
+#ifndef WARN_UNOPENED
+# define WARN_UNOPENED 11
+#endif
+
+#ifndef WARN_MISC
+# define WARN_MISC 12
+#endif
+
+#ifndef WARN_NUMERIC
+# define WARN_NUMERIC 13
+#endif
+
+#ifndef WARN_ONCE
+# define WARN_ONCE 14
+#endif
+
+#ifndef WARN_OVERFLOW
+# define WARN_OVERFLOW 15
+#endif
+
+#ifndef WARN_PACK
+# define WARN_PACK 16
+#endif
+
+#ifndef WARN_PORTABLE
+# define WARN_PORTABLE 17
+#endif
+
+#ifndef WARN_RECURSION
+# define WARN_RECURSION 18
+#endif
+
+#ifndef WARN_REDEFINE
+# define WARN_REDEFINE 19
+#endif
+
+#ifndef WARN_REGEXP
+# define WARN_REGEXP 20
+#endif
+
+#ifndef WARN_SEVERE
+# define WARN_SEVERE 21
+#endif
+
+#ifndef WARN_DEBUGGING
+# define WARN_DEBUGGING 22
+#endif
+
+#ifndef WARN_INPLACE
+# define WARN_INPLACE 23
+#endif
+
+#ifndef WARN_INTERNAL
+# define WARN_INTERNAL 24
+#endif
+
+#ifndef WARN_MALLOC
+# define WARN_MALLOC 25
+#endif
+
+#ifndef WARN_SIGNAL
+# define WARN_SIGNAL 26
+#endif
+
+#ifndef WARN_SUBSTR
+# define WARN_SUBSTR 27
+#endif
+
+#ifndef WARN_SYNTAX
+# define WARN_SYNTAX 28
+#endif
+
+#ifndef WARN_AMBIGUOUS
+# define WARN_AMBIGUOUS 29
+#endif
+
+#ifndef WARN_BAREWORD
+# define WARN_BAREWORD 30
+#endif
+
+#ifndef WARN_DIGIT
+# define WARN_DIGIT 31
+#endif
+
+#ifndef WARN_PARENTHESIS
+# define WARN_PARENTHESIS 32
+#endif
+
+#ifndef WARN_PRECEDENCE
+# define WARN_PRECEDENCE 33
+#endif
+
+#ifndef WARN_PRINTF
+# define WARN_PRINTF 34
+#endif
+
+#ifndef WARN_PROTOTYPE
+# define WARN_PROTOTYPE 35
+#endif
+
+#ifndef WARN_QW
+# define WARN_QW 36
+#endif
+
+#ifndef WARN_RESERVED
+# define WARN_RESERVED 37
+#endif
+
+#ifndef WARN_SEMICOLON
+# define WARN_SEMICOLON 38
+#endif
+
+#ifndef WARN_TAINT
+# define WARN_TAINT 39
+#endif
+
+#ifndef WARN_THREADS
+# define WARN_THREADS 40
+#endif
+
+#ifndef WARN_UNINITIALIZED
+# define WARN_UNINITIALIZED 41
+#endif
+
+#ifndef WARN_UNPACK
+# define WARN_UNPACK 42
+#endif
+
+#ifndef WARN_UNTIE
+# define WARN_UNTIE 43
+#endif
+
+#ifndef WARN_UTF8
+# define WARN_UTF8 44
+#endif
+
+#ifndef WARN_VOID
+# define WARN_VOID 45
+#endif
+
+#ifndef WARN_ASSERTIONS
+# define WARN_ASSERTIONS 46
+#endif
+#ifndef packWARN
+# define packWARN(a) (a)
+#endif
+
+#ifndef ckWARN
+# ifdef G_WARN_ON
+# define ckWARN(a) (PL_dowarn & G_WARN_ON)
+# else
+# define ckWARN(a) PL_dowarn
+# endif
+#endif
+
+#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner)
+#if defined(NEED_warner)
+static void DPPP_(my_warner)(U32 err, const char *pat, ...);
+static
+#else
+extern void DPPP_(my_warner)(U32 err, const char *pat, ...);
+#endif
+
+#define Perl_warner DPPP_(my_warner)
+
+#if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
+
+void
+DPPP_(my_warner)(U32 err, const char *pat, ...)
+{
+ SV *sv;
+ va_list args;
+
+ PERL_UNUSED_ARG(err);
+
+ va_start(args, pat);
+ sv = vnewSVpvf(pat, &args);
+ va_end(args);
+ sv_2mortal(sv);
+ warn("%s", SvPV_nolen(sv));
+}
+
+#define warner Perl_warner
+
+#define Perl_warner_nocontext Perl_warner
+
+#endif
+#endif
+
+/* concatenating with "" ensures that only literal strings are accepted as argument
+ * note that STR_WITH_LEN() can't be used as argument to macros or functions that
+ * under some configurations might be macros
+ */
+#ifndef STR_WITH_LEN
+# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
+#endif
+#ifndef newSVpvs
+# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
+#endif
+
+#ifndef newSVpvs_flags
+# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
+#endif
+
+#ifndef sv_catpvs
+# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
+#endif
+
+#ifndef sv_setpvs
+# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
+#endif
+
+#ifndef hv_fetchs
+# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval)
+#endif
+
+#ifndef hv_stores
+# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
+#endif
+#ifndef gv_fetchpvn_flags
+# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
+#endif
+
+#ifndef gv_fetchpvs
+# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
+#endif
+
+#ifndef gv_stashpvs
+# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
+#endif
+#ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#endif
+#ifndef PERL_MAGIC_sv
+# define PERL_MAGIC_sv '\0'
+#endif
+
+#ifndef PERL_MAGIC_overload
+# define PERL_MAGIC_overload 'A'
+#endif
+
+#ifndef PERL_MAGIC_overload_elem
+# define PERL_MAGIC_overload_elem 'a'
+#endif
+
+#ifndef PERL_MAGIC_overload_table
+# define PERL_MAGIC_overload_table 'c'
+#endif
+
+#ifndef PERL_MAGIC_bm
+# define PERL_MAGIC_bm 'B'
+#endif
+
+#ifndef PERL_MAGIC_regdata
+# define PERL_MAGIC_regdata 'D'
+#endif
+
+#ifndef PERL_MAGIC_regdatum
+# define PERL_MAGIC_regdatum 'd'
+#endif
+
+#ifndef PERL_MAGIC_env
+# define PERL_MAGIC_env 'E'
+#endif
+
+#ifndef PERL_MAGIC_envelem
+# define PERL_MAGIC_envelem 'e'
+#endif
+
+#ifndef PERL_MAGIC_fm
+# define PERL_MAGIC_fm 'f'
+#endif
+
+#ifndef PERL_MAGIC_regex_global
+# define PERL_MAGIC_regex_global 'g'
+#endif
+
+#ifndef PERL_MAGIC_isa
+# define PERL_MAGIC_isa 'I'
+#endif
+
+#ifndef PERL_MAGIC_isaelem
+# define PERL_MAGIC_isaelem 'i'
+#endif
+
+#ifndef PERL_MAGIC_nkeys
+# define PERL_MAGIC_nkeys 'k'
+#endif
+
+#ifndef PERL_MAGIC_dbfile
+# define PERL_MAGIC_dbfile 'L'
+#endif
+
+#ifndef PERL_MAGIC_dbline
+# define PERL_MAGIC_dbline 'l'
+#endif
+
+#ifndef PERL_MAGIC_mutex
+# define PERL_MAGIC_mutex 'm'
+#endif
+
+#ifndef PERL_MAGIC_shared
+# define PERL_MAGIC_shared 'N'
+#endif
+
+#ifndef PERL_MAGIC_shared_scalar
+# define PERL_MAGIC_shared_scalar 'n'
+#endif
+
+#ifndef PERL_MAGIC_collxfrm
+# define PERL_MAGIC_collxfrm 'o'
+#endif
+
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
+#ifndef PERL_MAGIC_tiedelem
+# define PERL_MAGIC_tiedelem 'p'
+#endif
+
+#ifndef PERL_MAGIC_tiedscalar
+# define PERL_MAGIC_tiedscalar 'q'
+#endif
+
+#ifndef PERL_MAGIC_qr
+# define PERL_MAGIC_qr 'r'
+#endif
+
+#ifndef PERL_MAGIC_sig
+# define PERL_MAGIC_sig 'S'
+#endif
+
+#ifndef PERL_MAGIC_sigelem
+# define PERL_MAGIC_sigelem 's'
+#endif
+
+#ifndef PERL_MAGIC_taint
+# define PERL_MAGIC_taint 't'
+#endif
+
+#ifndef PERL_MAGIC_uvar
+# define PERL_MAGIC_uvar 'U'
+#endif
+
+#ifndef PERL_MAGIC_uvar_elem
+# define PERL_MAGIC_uvar_elem 'u'
+#endif
+
+#ifndef PERL_MAGIC_vstring
+# define PERL_MAGIC_vstring 'V'
+#endif
+
+#ifndef PERL_MAGIC_vec
+# define PERL_MAGIC_vec 'v'
+#endif
+
+#ifndef PERL_MAGIC_utf8
+# define PERL_MAGIC_utf8 'w'
+#endif
+
+#ifndef PERL_MAGIC_substr
+# define PERL_MAGIC_substr 'x'
+#endif
+
+#ifndef PERL_MAGIC_defelem
+# define PERL_MAGIC_defelem 'y'
+#endif
+
+#ifndef PERL_MAGIC_glob
+# define PERL_MAGIC_glob '*'
+#endif
+
+#ifndef PERL_MAGIC_arylen
+# define PERL_MAGIC_arylen '#'
+#endif
+
+#ifndef PERL_MAGIC_pos
+# define PERL_MAGIC_pos '.'
+#endif
+
+#ifndef PERL_MAGIC_backref
+# define PERL_MAGIC_backref '<'
+#endif
+
+#ifndef PERL_MAGIC_ext
+# define PERL_MAGIC_ext '~'
+#endif
+
+/* That's the best we can do... */
+#ifndef sv_catpvn_nomg
+# define sv_catpvn_nomg sv_catpvn
+#endif
+
+#ifndef sv_catsv_nomg
+# define sv_catsv_nomg sv_catsv
+#endif
+
+#ifndef sv_setsv_nomg
+# define sv_setsv_nomg sv_setsv
+#endif
+
+#ifndef sv_pvn_nomg
+# define sv_pvn_nomg sv_pvn
+#endif
+
+#ifndef SvIV_nomg
+# define SvIV_nomg SvIV
+#endif
+
+#ifndef SvUV_nomg
+# define SvUV_nomg SvUV
+#endif
+
+#ifndef sv_catpv_mg
+# define sv_catpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catpvn_mg
+# define sv_catpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catsv_mg
+# define sv_catsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_catsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setiv_mg
+# define sv_setiv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setiv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setnv_mg
+# define sv_setnv_mg(sv, num) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setnv(TeMpSv,num); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpv_mg
+# define sv_setpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpvn_mg
+# define sv_setpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setsv_mg
+# define sv_setsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_setsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setuv_mg
+# define sv_setuv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setuv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_usepvn_mg
+# define sv_usepvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_usepvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+#ifndef SvVSTRING_mg
+# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
+#endif
+
+/* Hint: sv_magic_portable
+ * This is a compatibility function that is only available with
+ * Devel::PPPort. It is NOT in the perl core.
+ * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
+ * it is being passed a name pointer with namlen == 0. In that
+ * case, perl 5.8.0 and later store the pointer, not a copy of it.
+ * The compatibility can be provided back to perl 5.004. With
+ * earlier versions, the code will not compile.
+ */
+
+#if (PERL_BCDVERSION < 0x5004000)
+
+ /* code that uses sv_magic_portable will not compile */
+
+#elif (PERL_BCDVERSION < 0x5008000)
+
+# define sv_magic_portable(sv, obj, how, name, namlen) \
+ STMT_START { \
+ SV *SvMp_sv = (sv); \
+ char *SvMp_name = (char *) (name); \
+ I32 SvMp_namlen = (namlen); \
+ if (SvMp_name && SvMp_namlen == 0) \
+ { \
+ MAGIC *mg; \
+ sv_magic(SvMp_sv, obj, how, 0, 0); \
+ mg = SvMAGIC(SvMp_sv); \
+ mg->mg_len = -42; /* XXX: this is the tricky part */ \
+ mg->mg_ptr = SvMp_name; \
+ } \
+ else \
+ { \
+ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
+ } \
+ } STMT_END
+
+#else
+
+# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
+
+#endif
+
+#ifdef USE_ITHREADS
+#ifndef CopFILE
+# define CopFILE(c) ((c)->cop_file)
+#endif
+
+#ifndef CopFILEGV
+# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) ((c)->cop_stashpv)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
+ || (CopSTASHPV(c) && HvNAME(hv) \
+ && strEQ(CopSTASHPV(c), HvNAME(hv)))))
+#endif
+
+#else
+#ifndef CopFILEGV
+# define CopFILEGV(c) ((c)->cop_filegv)
+#endif
+
+#ifndef CopFILEGV_set
+# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
+#endif
+
+#ifndef CopFILE
+# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) ((c)->cop_stash)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+#endif
+
+#endif /* USE_ITHREADS */
+#ifndef IN_PERL_COMPILETIME
+# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE
+# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+#endif
+
+#ifndef IS_NUMBER_GREATER_THAN_UV_MAX
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef IS_NUMBER_NOT_INT
+# define IS_NUMBER_NOT_INT 0x04
+#endif
+
+#ifndef IS_NUMBER_NEG
+# define IS_NUMBER_NEG 0x08
+#endif
+
+#ifndef IS_NUMBER_INFINITY
+# define IS_NUMBER_INFINITY 0x10
+#endif
+
+#ifndef IS_NUMBER_NAN
+# define IS_NUMBER_NAN 0x20
+#endif
+#ifndef GROK_NUMERIC_RADIX
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+#endif
+#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
+# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef PERL_SCAN_SILENT_ILLDIGIT
+# define PERL_SCAN_SILENT_ILLDIGIT 0x04
+#endif
+
+#ifndef PERL_SCAN_ALLOW_UNDERSCORES
+# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
+#endif
+
+#ifndef PERL_SCAN_DISALLOW_PREFIX
+# define PERL_SCAN_DISALLOW_PREFIX 0x02
+#endif
+
+#ifndef grok_numeric_radix
+#if defined(NEED_grok_numeric_radix)
+static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+static
+#else
+extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+#endif
+
+#ifdef grok_numeric_radix
+# undef grok_numeric_radix
+#endif
+#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
+#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
+
+#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
+bool
+DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#ifdef PL_numeric_radix_sv
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* older perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h
+ */
+#include <locale.h>
+ dTHR; /* needed for older threaded perls */
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len = strlen(radix);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+#endif
+
+#ifndef grok_number
+#if defined(NEED_grok_number)
+static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+static
+#else
+extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+#endif
+
+#ifdef grok_number
+# undef grok_number
+#endif
+#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
+#define Perl_grok_number DPPP_(my_grok_number)
+
+#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
+int
+DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif
+#endif
+
+/*
+ * The grok_* routines have been modified to use warn() instead of
+ * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
+ * which is why the stack variable has been renamed to 'xdigit'.
+ */
+
+#ifndef grok_bin
+#if defined(NEED_grok_bin)
+static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+static
+#else
+extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+#endif
+
+#ifdef grok_bin
+# undef grok_bin
+#endif
+#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
+#define Perl_grok_bin DPPP_(my_grok_bin)
+
+#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
+UV
+DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_2 = UV_MAX / 2;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading b or 0b.
+ for compatibility silently suffer "b" and "0b" as valid binary
+ numbers. */
+ if (len >= 1) {
+ if (s[0] == 'b') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ char bit = *s;
+ if (bit == '0' || bit == '1') {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_bin. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_2) {
+ value = (value << 1) | (bit - '0');
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in binary number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 2.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount. */
+ value_nv += (NV)(bit - '0');
+ continue;
+ }
+ if (bit == '_' && len && allow_underscores && (bit = s[1])
+ && (bit == '0' || bit == '1'))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal binary digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Binary number > 0b11111111111111111111111111111111 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_hex
+#if defined(NEED_grok_hex)
+static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+static
+#else
+extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+#endif
+
+#ifdef grok_hex
+# undef grok_hex
+#endif
+#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
+#define Perl_grok_hex DPPP_(my_grok_hex)
+
+#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
+UV
+DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_16 = UV_MAX / 16;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+ const char *xdigit;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading x or 0x.
+ for compatibility silently suffer "x" and "0x" as valid hex numbers.
+ */
+ if (len >= 1) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ xdigit = strchr((char *) PL_hexdigit, *s);
+ if (xdigit) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_hex. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_16) {
+ value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ warn("Integer overflow in hexadecimal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 16.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 16-tuples. */
+ value_nv += (NV)((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ if (*s == '_' && len && allow_underscores && s[1]
+ && (xdigit = strchr((char *) PL_hexdigit, s[1])))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal hexadecimal digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Hexadecimal number > 0xffffffff non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_oct
+#if defined(NEED_grok_oct)
+static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+static
+#else
+extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
+#endif
+
+#ifdef grok_oct
+# undef grok_oct
+#endif
+#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
+#define Perl_grok_oct DPPP_(my_grok_oct)
+
+#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
+UV
+DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_8 = UV_MAX / 8;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ for (; len-- && *s; s++) {
+ /* gcc 2.95 optimiser not smart enough to figure that this subtraction
+ out front allows slicker code. */
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 7) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_8) {
+ value = (value << 3) | digit;
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in octal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 8.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 8-tuples. */
+ value_nv += (NV)digit;
+ continue;
+ }
+ if (digit == ('_' - '0') && len && allow_underscores
+ && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ /* Allow \octal to work the DWIM way (that is, stop scanning
+ * as soon as non-octal characters are seen, complain only iff
+ * someone seems to want to use the digits eight and nine). */
+ if (digit == 8 || digit == 9) {
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal octal digit '%c' ignored", *s);
+ }
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Octal number > 037777777777 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#if !defined(my_snprintf)
+#if defined(NEED_my_snprintf)
+static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
+static
+#else
+extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
+#endif
+
+#define my_snprintf DPPP_(my_my_snprintf)
+#define Perl_my_snprintf DPPP_(my_my_snprintf)
+
+#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
+
+int
+DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
+{
+ dTHX;
+ int retval;
+ va_list ap;
+ va_start(ap, format);
+#ifdef HAS_VSNPRINTF
+ retval = vsnprintf(buffer, len, format, ap);
+#else
+ retval = vsprintf(buffer, format, ap);
+#endif
+ va_end(ap);
+ if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
+ return retval;
+}
+
+#endif
+#endif
+
+#if !defined(my_sprintf)
+#if defined(NEED_my_sprintf)
+static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
+static
+#else
+extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
+#endif
+
+#define my_sprintf DPPP_(my_my_sprintf)
+#define Perl_my_sprintf DPPP_(my_my_sprintf)
+
+#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
+
+int
+DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vsprintf(buffer, pat, args);
+ va_end(args);
+ return strlen(buffer);
+}
+
+#endif
+#endif
+
+#ifdef NO_XSLOCKS
+# ifdef dJMPENV
+# define dXCPT dJMPENV; int rEtV = 0
+# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
+# define XCPT_TRY_END JMPENV_POP;
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW JMPENV_JUMP(rEtV)
+# else
+# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
+# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
+# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
+# endif
+#endif
+
+#if !defined(my_strlcat)
+#if defined(NEED_my_strlcat)
+static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
+static
+#else
+extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
+#endif
+
+#define my_strlcat DPPP_(my_my_strlcat)
+#define Perl_my_strlcat DPPP_(my_my_strlcat)
+
+#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
+
+Size_t
+DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
+{
+ Size_t used, length, copy;
+
+ used = strlen(dst);
+ length = strlen(src);
+ if (size > 0 && used < size - 1) {
+ copy = (length >= size - used) ? size - used - 1 : length;
+ memcpy(dst + used, src, copy);
+ dst[used + copy] = '\0';
+ }
+ return used + length;
+}
+#endif
+#endif
+
+#if !defined(my_strlcpy)
+#if defined(NEED_my_strlcpy)
+static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
+static
+#else
+extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
+#endif
+
+#define my_strlcpy DPPP_(my_my_strlcpy)
+#define Perl_my_strlcpy DPPP_(my_my_strlcpy)
+
+#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
+
+Size_t
+DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
+{
+ Size_t length, copy;
+
+ length = strlen(src);
+ if (size > 0) {
+ copy = (length >= size) ? size - 1 : length;
+ memcpy(dst, src, copy);
+ dst[copy] = '\0';
+ }
+ return length;
+}
+
+#endif
+#endif
+#ifndef PERL_PV_ESCAPE_QUOTE
+# define PERL_PV_ESCAPE_QUOTE 0x0001
+#endif
+
+#ifndef PERL_PV_PRETTY_QUOTE
+# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
+#endif
+
+#ifndef PERL_PV_PRETTY_ELLIPSES
+# define PERL_PV_PRETTY_ELLIPSES 0x0002
+#endif
+
+#ifndef PERL_PV_PRETTY_LTGT
+# define PERL_PV_PRETTY_LTGT 0x0004
+#endif
+
+#ifndef PERL_PV_ESCAPE_FIRSTCHAR
+# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008
+#endif
+
+#ifndef PERL_PV_ESCAPE_UNI
+# define PERL_PV_ESCAPE_UNI 0x0100
+#endif
+
+#ifndef PERL_PV_ESCAPE_UNI_DETECT
+# define PERL_PV_ESCAPE_UNI_DETECT 0x0200
+#endif
+
+#ifndef PERL_PV_ESCAPE_ALL
+# define PERL_PV_ESCAPE_ALL 0x1000
+#endif
+
+#ifndef PERL_PV_ESCAPE_NOBACKSLASH
+# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000
+#endif
+
+#ifndef PERL_PV_ESCAPE_NOCLEAR
+# define PERL_PV_ESCAPE_NOCLEAR 0x4000
+#endif
+
+#ifndef PERL_PV_ESCAPE_RE
+# define PERL_PV_ESCAPE_RE 0x8000
+#endif
+
+#ifndef PERL_PV_PRETTY_NOCLEAR
+# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
+#endif
+#ifndef PERL_PV_PRETTY_DUMP
+# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
+#endif
+
+#ifndef PERL_PV_PRETTY_REGPROP
+# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
+#endif
+
+/* Hint: pv_escape
+ * Note that unicode functionality is only backported to
+ * those perl versions that support it. For older perl
+ * versions, the implementation will fall back to bytes.
+ */
+
+#ifndef pv_escape
+#if defined(NEED_pv_escape)
+static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
+static
+#else
+extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
+#endif
+
+#ifdef pv_escape
+# undef pv_escape
+#endif
+#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f)
+#define Perl_pv_escape DPPP_(my_pv_escape)
+
+#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL)
+
+char *
+DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str,
+ const STRLEN count, const STRLEN max,
+ STRLEN * const escaped, const U32 flags)
+{
+ const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
+ const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
+ char octbuf[32] = "%123456789ABCDF";
+ STRLEN wrote = 0;
+ STRLEN chsize = 0;
+ STRLEN readsize = 1;
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+ bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
+#endif
+ const char *pv = str;
+ const char * const end = pv + count;
+ octbuf[0] = esc;
+
+ if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
+ sv_setpvs(dsv, "");
+
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+ if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
+ isuni = 1;
+#endif
+
+ for (; pv < end && (!max || wrote < max) ; pv += readsize) {
+ const UV u =
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+ isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
+#endif
+ (U8)*pv;
+ const U8 c = (U8)u & 0xFF;
+
+ if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
+ if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
+ chsize = my_snprintf(octbuf, sizeof octbuf,
+ "%"UVxf, u);
+ else
+ chsize = my_snprintf(octbuf, sizeof octbuf,
+ "%cx{%"UVxf"}", esc, u);
+ } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
+ chsize = 1;
+ } else {
+ if (c == dq || c == esc || !isPRINT(c)) {
+ chsize = 2;
+ switch (c) {
+ case '\\' : /* fallthrough */
+ case '%' : if (c == esc)
+ octbuf[1] = esc;
+ else
+ chsize = 1;
+ break;
+ case '\v' : octbuf[1] = 'v'; break;
+ case '\t' : octbuf[1] = 't'; break;
+ case '\r' : octbuf[1] = 'r'; break;
+ case '\n' : octbuf[1] = 'n'; break;
+ case '\f' : octbuf[1] = 'f'; break;
+ case '"' : if (dq == '"')
+ octbuf[1] = '"';
+ else
+ chsize = 1;
+ break;
+ default: chsize = my_snprintf(octbuf, sizeof octbuf,
+ pv < end && isDIGIT((U8)*(pv+readsize))
+ ? "%c%03o" : "%c%o", esc, c);
+ }
+ } else {
+ chsize = 1;
+ }
+ }
+ if (max && wrote + chsize > max) {
+ break;
+ } else if (chsize > 1) {
+ sv_catpvn(dsv, octbuf, chsize);
+ wrote += chsize;
+ } else {
+ char tmp[2];
+ my_snprintf(tmp, sizeof tmp, "%c", c);
+ sv_catpvn(dsv, tmp, 1);
+ wrote++;
+ }
+ if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
+ break;
+ }
+ if (escaped != NULL)
+ *escaped= pv - str;
+ return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+#ifndef pv_pretty
+#if defined(NEED_pv_pretty)
+static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
+static
+#else
+extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
+#endif
+
+#ifdef pv_pretty
+# undef pv_pretty
+#endif
+#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
+#define Perl_pv_pretty DPPP_(my_pv_pretty)
+
+#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
+
+char *
+DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count,
+ const STRLEN max, char const * const start_color, char const * const end_color,
+ const U32 flags)
+{
+ const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
+ STRLEN escaped;
+
+ if (!(flags & PERL_PV_PRETTY_NOCLEAR))
+ sv_setpvs(dsv, "");
+
+ if (dq == '"')
+ sv_catpvs(dsv, "\"");
+ else if (flags & PERL_PV_PRETTY_LTGT)
+ sv_catpvs(dsv, "<");
+
+ if (start_color != NULL)
+ sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
+
+ pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
+
+ if (end_color != NULL)
+ sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
+
+ if (dq == '"')
+ sv_catpvs(dsv, "\"");
+ else if (flags & PERL_PV_PRETTY_LTGT)
+ sv_catpvs(dsv, ">");
+
+ if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
+ sv_catpvs(dsv, "...");
+
+ return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+#ifndef pv_display
+#if defined(NEED_pv_display)
+static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
+static
+#else
+extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
+#endif
+
+#ifdef pv_display
+# undef pv_display
+#endif
+#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e)
+#define Perl_pv_display DPPP_(my_pv_display)
+
+#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL)
+
+char *
+DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+{
+ pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
+ if (len > cur && pv[cur] == '\0')
+ sv_catpvs(dsv, "\\0");
+ return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
diff --git a/Master/tlpkg/tlperl/lib/Devel/Peek.pm b/Master/tlpkg/tlperl/lib/Devel/Peek.pm
new file mode 100644
index 00000000000..2fced312f2e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/Peek.pm
@@ -0,0 +1,570 @@
+# Devel::Peek - A data debugging tool for the XS programmer
+# The documentation is after the __END__
+
+package Devel::Peek;
+
+$VERSION = '1.04';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+require Exporter;
+use XSLoader ();
+
+@ISA = qw(Exporter);
+@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg
+ fill_mstats mstats_fillhash mstats2hash runops_debug debug_flags);
+@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
+%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
+
+XSLoader::load 'Devel::Peek';
+
+sub import {
+ my $c = shift;
+ my $ops_rx = qr/^:opd(=[stP]*)?\b/;
+ my @db = grep m/$ops_rx/, @_;
+ @_ = grep !m/$ops_rx/, @_;
+ if (@db) {
+ die "Too many :opd options" if @db > 1;
+ runops_debug(1);
+ my $flags = ($db[0] =~ m/$ops_rx/ and $1);
+ $flags = 'st' unless defined $flags;
+ my $f = 0;
+ $f |= 2 if $flags =~ /s/;
+ $f |= 8 if $flags =~ /t/;
+ $f |= 64 if $flags =~ /P/;
+ $^D |= $f if $f;
+ }
+ unshift @_, $c;
+ goto &Exporter::import;
+}
+
+sub DumpWithOP ($;$) {
+ local($Devel::Peek::dump_ops)=1;
+ my $depth = @_ > 1 ? $_[1] : 4 ;
+ Dump($_[0],$depth);
+}
+
+$D_flags = 'psltocPmfrxuLHXDSTR';
+
+sub debug_flags (;$) {
+ my $out = "";
+ for my $i (0 .. length($D_flags)-1) {
+ $out .= substr $D_flags, $i, 1 if $^D & (1<<$i);
+ }
+ my $arg = shift;
+ my $num = $arg;
+ if (defined $arg and $arg =~ /\D/) {
+ die "unknown flags in debug_flags()" if $arg =~ /[^-$D_flags]/;
+ my ($on,$off) = split /-/, "$arg-";
+ $num = $^D;
+ $num |= (1<<index($D_flags, $_)) for split //, $on;
+ $num &= ~(1<<index($D_flags, $_)) for split //, $off;
+ }
+ $^D = $num if defined $arg;
+ $out
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Devel::Peek - A data debugging tool for the XS programmer
+
+=head1 SYNOPSIS
+
+ use Devel::Peek;
+ Dump( $a );
+ Dump( $a, 5 );
+ DumpArray( 5, $a, $b, ... );
+ mstat "Point 5";
+
+ use Devel::Peek ':opd=st';
+
+=head1 DESCRIPTION
+
+Devel::Peek contains functions which allows raw Perl datatypes to be
+manipulated from a Perl script. This is used by those who do XS programming
+to check that the data they are sending from C to Perl looks as they think
+it should look. The trick, then, is to know what the raw datatype is
+supposed to look like when it gets to Perl. This document offers some tips
+and hints to describe good and bad raw data.
+
+It is very possible that this document will fall far short of being useful
+to the casual reader. The reader is expected to understand the material in
+the first few sections of L<perlguts>.
+
+Devel::Peek supplies a C<Dump()> function which can dump a raw Perl
+datatype, and C<mstat("marker")> function to report on memory usage
+(if perl is compiled with corresponding option). The function
+DeadCode() provides statistics on the data "frozen" into inactive
+C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and
+C<SvREFCNT_dec()> which can query, increment, and decrement reference
+counts on SVs. This document will take a passive, and safe, approach
+to data debugging and for that it will describe only the C<Dump()>
+function.
+
+Function C<DumpArray()> allows dumping of multiple values (useful when you
+need to analyze returns of functions).
+
+The global variable $Devel::Peek::pv_limit can be set to limit the
+number of character printed in various string values. Setting it to 0
+means no limit.
+
+If C<use Devel::Peek> directive has a C<:opd=FLAGS> argument,
+this switches on debugging of opcode dispatch. C<FLAGS> should be a
+combination of C<s>, C<t>, and C<P> (see B<-D> flags in L<perlrun>).
+C<:opd> is a shortcut for C<:opd=st>.
+
+=head2 Runtime debugging
+
+C<CvGV($cv)> return one of the globs associated to a subroutine reference $cv.
+
+debug_flags() returns a string representation of C<$^D> (similar to
+what is allowed for B<-D> flag). When called with a numeric argument,
+sets $^D to the corresponding value. When called with an argument of
+the form C<"flags-flags">, set on/off bits of C<$^D> corresponding to
+letters before/after C<->. (The returned value is for C<$^D> before
+the modification.)
+
+runops_debug() returns true if the current I<opcode dispatcher> is the
+debugging one. When called with an argument, switches to debugging or
+non-debugging dispatcher depending on the argument (active for
+newly-entered subs/etc only). (The returned value is for the dispatcher before the modification.)
+
+=head2 Memory footprint debugging
+
+When perl is compiled with support for memory footprint debugging
+(default with Perl's malloc()), Devel::Peek provides an access to this API.
+
+Use mstat() function to emit a memory state statistic to the terminal.
+For more information on the format of output of mstat() see
+L<perldebguts/Using C<$ENV{PERL_DEBUG_MSTATS}>>.
+
+Three additional functions allow access to this statistic from Perl.
+First, use C<mstats_fillhash(%hash)> to get the information contained
+in the output of mstat() into %hash. The field of this hash are
+
+ minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack
+ topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree
+
+Two additional fields C<free>, C<used> contain array references which
+provide per-bucket count of free and used chunks. Two other fields
+C<mem_size>, C<available_size> contain array references which provide
+the information about the allocated size and usable size of chunks in
+each bucket. Again, see L<perldebguts/Using C<$ENV{PERL_DEBUG_MSTATS}>>
+for details.
+
+Keep in mind that only the first several "odd-numbered" buckets are
+used, so the information on size of the "odd-numbered" buckets which are
+not used is probably meaningless.
+
+The information in
+
+ mem_size available_size minbucket nbuckets
+
+is the property of a particular build of perl, and does not depend on
+the current process. If you do not provide the optional argument to
+the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then
+the information in fields C<mem_size>, C<available_size> is not
+updated.
+
+C<fill_mstats($buf)> is a much cheaper call (both speedwise and
+memory-wise) which collects the statistic into $buf in
+machine-readable form. At a later moment you may need to call
+C<mstats2hash($buf, %hash)> to use this information to fill %hash.
+
+All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and
+C<mstats2hash($buf, %hash)> are designed to allocate no memory if used
+I<the second time> on the same $buf and/or %hash.
+
+So, if you want to collect memory info in a cycle, you may call
+
+ $#buf = 999;
+ fill_mstats($_) for @buf;
+ mstats_fillhash(%report, 1); # Static info too
+
+ foreach (@buf) {
+ # Do something...
+ fill_mstats $_; # Collect statistic
+ }
+ foreach (@buf) {
+ mstats2hash($_, %report); # Preserve static info
+ # Do something with %report
+ }
+
+=head1 EXAMPLES
+
+The following examples don't attempt to show everything as that would be a
+monumental task, and, frankly, we don't want this manpage to be an internals
+document for Perl. The examples do demonstrate some basics of the raw Perl
+datatypes, and should suffice to get most determined people on their way.
+There are no guidewires or safety nets, nor blazed trails, so be prepared to
+travel alone from this point and on and, if at all possible, don't fall into
+the quicksand (it's bad for business).
+
+Oh, one final bit of advice: take L<perlguts> with you. When you return we
+expect to see it well-thumbed.
+
+=head2 A simple scalar string
+
+Let's begin by looking a simple scalar which is holding a string.
+
+ use Devel::Peek;
+ $a = "hello";
+ Dump $a;
+
+The output:
+
+ SV = PVIV(0xbc288)
+ REFCNT = 1
+ FLAGS = (POK,pPOK)
+ IV = 0
+ PV = 0xb2048 "hello"\0
+ CUR = 5
+ LEN = 6
+
+This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string.
+Its reference count is 1. It has the C<POK> flag set, meaning its
+current PV field is valid. Because POK is set we look at the PV item
+to see what is in the scalar. The \0 at the end indicate that this
+PV is properly NUL-terminated.
+If the FLAGS had been IOK we would look
+at the IV item. CUR indicates the number of characters in the PV.
+LEN indicates the number of bytes requested for the PV (one more than
+CUR, in this case, because LEN includes an extra byte for the
+end-of-string marker).
+
+=head2 A simple scalar number
+
+If the scalar contains a number the raw SV will be leaner.
+
+ use Devel::Peek;
+ $a = 42;
+ Dump $a;
+
+The output:
+
+ SV = IV(0xbc818)
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 42
+
+This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its
+reference count is 1. It has the C<IOK> flag set, meaning it is currently
+being evaluated as a number. Because IOK is set we look at the IV item to
+see what is in the scalar.
+
+=head2 A simple scalar with an extra reference
+
+If the scalar from the previous example had an extra reference:
+
+ use Devel::Peek;
+ $a = 42;
+ $b = \$a;
+ Dump $a;
+
+The output:
+
+ SV = IV(0xbe860)
+ REFCNT = 2
+ FLAGS = (IOK,pIOK)
+ IV = 42
+
+Notice that this example differs from the previous example only in its
+reference count. Compare this to the next example, where we dump C<$b>
+instead of C<$a>.
+
+=head2 A reference to a simple scalar
+
+This shows what a reference looks like when it references a simple scalar.
+
+ use Devel::Peek;
+ $a = 42;
+ $b = \$a;
+ Dump $b;
+
+The output:
+
+ SV = RV(0xf041c)
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0xbab08
+ SV = IV(0xbe860)
+ REFCNT = 2
+ FLAGS = (IOK,pIOK)
+ IV = 42
+
+Starting from the top, this says C<$b> is an SV. The scalar is an RV, a
+reference. It has the C<ROK> flag set, meaning it is a reference. Because
+ROK is set we have an RV item rather than an IV or PV. Notice that Dump
+follows the reference and shows us what C<$b> was referencing. We see the
+same C<$a> that we found in the previous example.
+
+Note that the value of C<RV> coincides with the numbers we see when we
+stringify $b. The addresses inside RV() and IV() are addresses of
+C<X***> structure which holds the current state of an C<SV>. This
+address may change during lifetime of an SV.
+
+=head2 A reference to an array
+
+This shows what a reference to an array looks like.
+
+ use Devel::Peek;
+ $a = [42];
+ Dump $a;
+
+The output:
+
+ SV = RV(0xf041c)
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0xb2850
+ SV = PVAV(0xbd448)
+ REFCNT = 1
+ FLAGS = ()
+ IV = 0
+ NV = 0
+ ARRAY = 0xb2048
+ ALLOC = 0xb2048
+ FILL = 0
+ MAX = 0
+ ARYLEN = 0x0
+ FLAGS = (REAL)
+ Elt No. 0 0xb5658
+ SV = IV(0xbe860)
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 42
+
+This says C<$a> is an SV and that it is an RV. That RV points to
+another SV which is a PVAV, an array. The array has one element,
+element zero, which is another SV. The field C<FILL> above indicates
+the last element in the array, similar to C<$#$a>.
+
+If C<$a> pointed to an array of two elements then we would see the
+following.
+
+ use Devel::Peek 'Dump';
+ $a = [42,24];
+ Dump $a;
+
+The output:
+
+ SV = RV(0xf041c)
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0xb2850
+ SV = PVAV(0xbd448)
+ REFCNT = 1
+ FLAGS = ()
+ IV = 0
+ NV = 0
+ ARRAY = 0xb2048
+ ALLOC = 0xb2048
+ FILL = 0
+ MAX = 0
+ ARYLEN = 0x0
+ FLAGS = (REAL)
+ Elt No. 0 0xb5658
+ SV = IV(0xbe860)
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 42
+ Elt No. 1 0xb5680
+ SV = IV(0xbe818)
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 24
+
+Note that C<Dump> will not report I<all> the elements in the array,
+only several first (depending on how deep it already went into the
+report tree).
+
+=head2 A reference to a hash
+
+The following shows the raw form of a reference to a hash.
+
+ use Devel::Peek;
+ $a = {hello=>42};
+ Dump $a;
+
+The output:
+
+ SV = RV(0x8177858) at 0x816a618
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0x814fc10
+ SV = PVHV(0x8167768) at 0x814fc10
+ REFCNT = 1
+ FLAGS = (SHAREKEYS)
+ IV = 1
+ NV = 0
+ ARRAY = 0x816c5b8 (0:7, 1:1)
+ hash quality = 100.0%
+ KEYS = 1
+ FILL = 1
+ MAX = 7
+ RITER = -1
+ EITER = 0x0
+ Elt "hello" HASH = 0xc8fd181b
+ SV = IV(0x816c030) at 0x814fcf4
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 42
+
+This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a
+hash. Fields RITER and EITER are used by C<L<each>>.
+
+The "quality" of a hash is defined as the total number of comparisons needed
+to access every element once, relative to the expected number needed for a
+random hash. The value can go over 100%.
+
+The total number of comparisons is equal to the sum of the squares of the
+number of entries in each bucket. For a random hash of C<<n>> keys into
+C<<k>> buckets, the expected value is:
+
+ n + n(n-1)/2k
+
+=head2 Dumping a large array or hash
+
+The C<Dump()> function, by default, dumps up to 4 elements from a
+toplevel array or hash. This number can be increased by supplying a
+second argument to the function.
+
+ use Devel::Peek;
+ $a = [10,11,12,13,14];
+ Dump $a;
+
+Notice that C<Dump()> prints only elements 10 through 13 in the above code.
+The following code will print all of the elements.
+
+ use Devel::Peek 'Dump';
+ $a = [10,11,12,13,14];
+ Dump $a, 5;
+
+=head2 A reference to an SV which holds a C pointer
+
+This is what you really need to know as an XS programmer, of course. When
+an XSUB returns a pointer to a C structure that pointer is stored in an SV
+and a reference to that SV is placed on the XSUB stack. So the output from
+an XSUB which uses something like the T_PTROBJ map might look something like
+this:
+
+ SV = RV(0xf381c)
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0xb8ad8
+ SV = PVMG(0xbb3c8)
+ REFCNT = 1
+ FLAGS = (OBJECT,IOK,pIOK)
+ IV = 729160
+ NV = 0
+ PV = 0
+ STASH = 0xc1d10 "CookBookB::Opaque"
+
+This shows that we have an SV which is an RV. That RV points at another
+SV. In this case that second SV is a PVMG, a blessed scalar. Because it is
+blessed it has the C<OBJECT> flag set. Note that an SV which holds a C
+pointer also has the C<IOK> flag set. The C<STASH> is set to the package
+name which this SV was blessed into.
+
+The output from an XSUB which uses something like the T_PTRREF map, which
+doesn't bless the object, might look something like this:
+
+ SV = RV(0xf381c)
+ REFCNT = 1
+ FLAGS = (ROK)
+ RV = 0xb8ad8
+ SV = PVMG(0xbb3c8)
+ REFCNT = 1
+ FLAGS = (IOK,pIOK)
+ IV = 729160
+ NV = 0
+ PV = 0
+
+=head2 A reference to a subroutine
+
+Looks like this:
+
+ SV = RV(0x798ec)
+ REFCNT = 1
+ FLAGS = (TEMP,ROK)
+ RV = 0x1d453c
+ SV = PVCV(0x1c768c)
+ REFCNT = 2
+ FLAGS = ()
+ IV = 0
+ NV = 0
+ COMP_STASH = 0x31068 "main"
+ START = 0xb20e0
+ ROOT = 0xbece0
+ XSUB = 0x0
+ XSUBANY = 0
+ GVGV::GV = 0x1d44e8 "MY" :: "top_targets"
+ FILE = "(eval 5)"
+ DEPTH = 0
+ PADLIST = 0x1c9338
+
+This shows that
+
+=over 4
+
+=item *
+
+the subroutine is not an XSUB (since C<START> and C<ROOT> are
+non-zero, and C<XSUB> is zero);
+
+=item *
+
+that it was compiled in the package C<main>;
+
+=item *
+
+under the name C<MY::top_targets>;
+
+=item *
+
+inside a 5th eval in the program;
+
+=item *
+
+it is not currently executed (see C<DEPTH>);
+
+=item *
+
+it has no prototype (C<PROTOTYPE> field is missing).
+
+=back
+
+=head1 EXPORTS
+
+C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and
+C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by
+default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and
+C<SvREFCNT_dec>.
+
+=head1 BUGS
+
+Readers have been known to skip important parts of L<perlguts>, causing much
+frustration for all.
+
+=head1 AUTHOR
+
+Ilya Zakharevich ilya@math.ohio-state.edu
+
+Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Author of this software makes no claim whatsoever about suitability,
+reliability, edability, editability or usability of this product, and
+should not be kept liable for any damage resulting from the use of
+it. If you can use it, you are in luck, if not, I should not be kept
+responsible. Keep a handy copy of your backup tape at hand.
+
+=head1 SEE ALSO
+
+L<perlguts>, and L<perlguts>, again.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm b/Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm
new file mode 100644
index 00000000000..bfdb4430d00
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm
@@ -0,0 +1,152 @@
+package Devel::SelfStubber;
+use File::Spec;
+require SelfLoader;
+@ISA = qw(SelfLoader);
+@EXPORT = 'AUTOLOAD';
+$JUST_STUBS = 1;
+$VERSION = 1.03;
+sub Version {$VERSION}
+
+# Use as
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
+# (LIB defaults to '.') e.g.
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
+# would print out stubs needed if you added a __DATA__ before the subs.
+# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
+# module with the stubs entered just before the __DATA__
+
+sub _add_to_cache {
+ my($self,$fullname,$pack,$lines, $prototype) = @_;
+ push(@DATA,@{$lines});
+ if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
+ '1;';
+}
+
+sub _package_defined {
+ my($self,$line) = @_;
+ push(@DATA,$line);
+}
+
+sub stub {
+ my($self,$module,$lib) = @_;
+ my($line,$end_data,$fh,$mod_file,$found_selfloader);
+ $lib ||= File::Spec->curdir();
+ ($mod_file = $module) =~ s,::,/,g;
+ $mod_file =~ tr|/|:| if $^O eq 'MacOS';
+
+ $mod_file = File::Spec->catfile($lib, "$mod_file.pm");
+ $fh = "${module}::DATA";
+ my (@BEFORE_DATA, @AFTER_DATA, @AFTER_END);
+ @DATA = @STUBS = ();
+
+ open($fh,$mod_file) || die "Unable to open $mod_file";
+ local $/ = "\n";
+ while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
+ push(@BEFORE_DATA,$line);
+ $line =~ /use\s+SelfLoader/ && $found_selfloader++;
+ }
+ (defined ($line) && $line =~ m/^__DATA__/)
+ || die "$mod_file doesn't contain a __DATA__ token";
+ $found_selfloader ||
+ print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
+ if ($JUST_STUBS) {
+ $self->_load_stubs($module);
+ } else {
+ $self->_load_stubs($module, \@AFTER_END);
+ }
+ if ( fileno($fh) ) {
+ $end_data = 1;
+ while(defined($line = <$fh>)) {
+ push(@AFTER_DATA,$line);
+ }
+ }
+ close($fh);
+ unless ($JUST_STUBS) {
+ print @BEFORE_DATA;
+ }
+ print @STUBS;
+ unless ($JUST_STUBS) {
+ print "1;\n__DATA__\n",@DATA;
+ if($end_data) { print "__END__ DATA\n",@AFTER_DATA; }
+ if(@AFTER_END) { print "__END__\n",@AFTER_END; }
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Devel::SelfStubber - generate stubs for a SelfLoading module
+
+=head1 SYNOPSIS
+
+To generate just the stubs:
+
+ use Devel::SelfStubber;
+ Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+or to generate the whole module with stubs inserted correctly
+
+ use Devel::SelfStubber;
+ $Devel::SelfStubber::JUST_STUBS=0;
+ Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
+NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.
+
+MY_LIB_DIR defaults to '.' if not present.
+
+=head1 DESCRIPTION
+
+Devel::SelfStubber prints the stubs you need to put in the module
+before the __DATA__ token (or you can get it to print the entire
+module with stubs correctly placed). The stubs ensure that if
+a method is called, it will get loaded. They are needed specifically
+for inherited autoloaded methods.
+
+This is best explained using the following example:
+
+Assume four classes, A,B,C & D.
+
+A is the root class, B is a subclass of A, C is a subclass of B,
+and D is another subclass of A.
+
+ A
+ / \
+ B D
+ /
+ C
+
+If D calls an autoloaded method 'foo' which is defined in class A,
+then the method is loaded into class A, then executed. If C then
+calls method 'foo', and that method was reimplemented in class
+B, but set to be autoloaded, then the lookup mechanism never gets to
+the AUTOLOAD mechanism in B because it first finds the method
+already loaded in A, and so erroneously uses that. If the method
+foo had been stubbed in B, then the lookup mechanism would have
+found the stub, and correctly loaded and used the sub from B.
+
+So, for classes and subclasses to have inheritance correctly
+work with autoloading, you need to ensure stubs are loaded.
+
+The SelfLoader can load stubs automatically at module initialization
+with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
+avoid having the stub loading overhead associated with your
+initialization (though note that the SelfLoader::load_stubs method
+will be called sooner or later - at latest when the first sub
+is being autoloaded). In this case, you can put the sub stubs
+before the __DATA__ token. This can be done manually, but this
+module allows automatic generation of the stubs.
+
+By default it just prints the stubs, but you can set the
+global $Devel::SelfStubber::JUST_STUBS to 0 and it will
+print out the entire module with the stubs positioned correctly.
+
+At the very least, this is useful to see what the SelfLoader
+thinks are stubs - in order to ensure future versions of the
+SelfStubber remain in step with the SelfLoader, the
+SelfStubber actually uses the SelfLoader to determine which
+stubs are needed.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Digest/MD5.pm b/Master/tlpkg/tlperl/lib/Digest/MD5.pm
new file mode 100644
index 00000000000..4e2adbe3460
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest/MD5.pm
@@ -0,0 +1,376 @@
+package Digest::MD5;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '2.39';
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(md5 md5_hex md5_base64);
+
+eval {
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ my $err = $@;
+ *add_bits = sub { die $err };
+}
+
+
+eval {
+ require XSLoader;
+ XSLoader::load('Digest::MD5', $VERSION);
+};
+if ($@) {
+ my $olderr = $@;
+ eval {
+ # Try to load the pure perl version
+ require Digest::Perl::MD5;
+
+ Digest::Perl::MD5->import(qw(md5 md5_hex md5_base64));
+ push(@ISA, "Digest::Perl::MD5"); # make OO interface work
+ };
+ if ($@) {
+ # restore the original error
+ die $olderr;
+ }
+}
+else {
+ *reset = \&new;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::MD5 - Perl interface to the MD5 Algorithm
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::MD5 qw(md5 md5_hex md5_base64);
+
+ $digest = md5($data);
+ $digest = md5_hex($data);
+ $digest = md5_base64($data);
+
+ # OO style
+ use Digest::MD5;
+
+ $ctx = Digest::MD5->new;
+
+ $ctx->add($data);
+ $ctx->addfile(*FILE);
+
+ $digest = $ctx->digest;
+ $digest = $ctx->hexdigest;
+ $digest = $ctx->b64digest;
+
+=head1 DESCRIPTION
+
+The C<Digest::MD5> module allows you to use the RSA Data Security
+Inc. MD5 Message Digest algorithm from within Perl programs. The
+algorithm takes as input a message of arbitrary length and produces as
+output a 128-bit "fingerprint" or "message digest" of the input.
+
+Note that the MD5 algorithm is not as strong as it used to be. It has
+since 2005 been easy to generate different messages that produce the
+same MD5 digest. It still seems hard to generate messages that
+produce a given digest, but it is probably wise to move to stronger
+algorithms for applications that depend on the digest to uniquely identify
+a message.
+
+The C<Digest::MD5> module provide a procedural interface for simple
+use, as well as an object oriented interface that can handle messages
+of arbitrary length and which can read files directly.
+
+=head1 FUNCTIONS
+
+The following functions are provided by the C<Digest::MD5> module.
+None of these functions are exported by default.
+
+=over 4
+
+=item md5($data,...)
+
+This function will concatenate all arguments, calculate the MD5 digest
+of this "message", and return it in binary form. The returned string
+will be 16 bytes long.
+
+The result of md5("a", "b", "c") will be exactly the same as the
+result of md5("abc").
+
+=item md5_hex($data,...)
+
+Same as md5(), but will return the digest in hexadecimal form. The
+length of the returned string will be 32 and it will only contain
+characters from this set: '0'..'9' and 'a'..'f'.
+
+=item md5_base64($data,...)
+
+Same as md5(), but will return the digest as a base64 encoded string.
+The length of the returned string will be 22 and it will only contain
+characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and
+'/'.
+
+Note that the base64 encoded string returned is not padded to be a
+multiple of 4 bytes long. If you want interoperability with other
+base64 encoded md5 digests you might want to append the redundant
+string "==" to the result.
+
+=back
+
+=head1 METHODS
+
+The object oriented interface to C<Digest::MD5> is described in this
+section. After a C<Digest::MD5> object has been created, you will add
+data to it and finally ask for the digest in a suitable format. A
+single object can be used to calculate multiple digests.
+
+The following methods are provided:
+
+=over 4
+
+=item $md5 = Digest::MD5->new
+
+The constructor returns a new C<Digest::MD5> object which encapsulate
+the state of the MD5 message-digest algorithm.
+
+If called as an instance method (i.e. $md5->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.
+
+=item $md5->reset
+
+This is just an alias for $md5->new.
+
+=item $md5->clone
+
+This a copy of the $md5 object. It is useful when you do not want to
+destroy the digests state, but need an intermediate value of the
+digest, e.g. when calculating digests iteratively on a continuous data
+stream. Example:
+
+ my $md5 = Digest::MD5->new;
+ while (<>) {
+ $md5->add($_);
+ print "Line $.: ", $md5->clone->hexdigest, "\n";
+ }
+
+=item $md5->add($data,...)
+
+The $data provided as argument are appended to the message we
+calculate the digest for. The return value is the $md5 object itself.
+
+All these lines will have the same effect on the state of the $md5
+object:
+
+ $md5->add("a"); $md5->add("b"); $md5->add("c");
+ $md5->add("a")->add("b")->add("c");
+ $md5->add("a", "b", "c");
+ $md5->add("abc");
+
+=item $md5->addfile($io_handle)
+
+The $io_handle will be read until EOF and its content appended to the
+message we calculate the digest for. The return value is the $md5
+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 $md5
+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 $md5 object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+C<binmode> before you pass it as argument to the addfile() method.
+
+=item $md5->add_bits($data, $nbits)
+
+=item $md5->add_bits($bitstring)
+
+Since the MD5 algorithm is byte oriented you might only add bits as
+multiples of 8, so you probably want to just use add() instead. The
+add_bits() method is provided for compatibility with other digest
+implementations. See L<Digest> for description of the arguments
+that add_bits() take.
+
+=item $md5->digest
+
+Return the binary digest for the message. The returned string will be
+16 bytes long.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the C<Digest::MD5>
+object is automatically C<reset> and can be used to calculate another
+digest value. Call $md5->clone->digest if you want to calculate the
+digest without resetting the digest state.
+
+=item $md5->hexdigest
+
+Same as $md5->digest, but will return the digest in hexadecimal
+form. The length of the returned string will be 32 and it will only
+contain characters from this set: '0'..'9' and 'a'..'f'.
+
+=item $md5->b64digest
+
+Same as $md5->digest, but will return the digest as a base64 encoded
+string. The length of the returned string will be 22 and it will only
+contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+'
+and '/'.
+
+
+The base64 encoded string returned is not padded to be a multiple of 4
+bytes long. If you want interoperability with other base64 encoded
+md5 digests you might want to append the string "==" to the result.
+
+=back
+
+
+=head1 EXAMPLES
+
+The simplest way to use this library is to import the md5_hex()
+function (or one of its cousins):
+
+ use Digest::MD5 qw(md5_hex);
+ print "Digest is ", md5_hex("foobarbaz"), "\n";
+
+The above example would print out the message:
+
+ Digest is 6df23dc03f9b54cc38a0fc1483df6e21
+
+The same checksum can also be calculated in OO style:
+
+ use Digest::MD5;
+
+ $md5 = Digest::MD5->new;
+ $md5->add('foo', 'bar');
+ $md5->add('baz');
+ $digest = $md5->hexdigest;
+
+ print "Digest is $digest\n";
+
+With OO style you can break the message arbitrary. This means that we
+are no longer limited to have space for the whole message in memory, i.e.
+we can handle messages of any size.
+
+This is useful when calculating checksum for files:
+
+ use Digest::MD5;
+
+ my $file = shift || "/etc/passwd";
+ open(FILE, $file) or die "Can't open '$file': $!";
+ binmode(FILE);
+
+ $md5 = Digest::MD5->new;
+ while (<FILE>) {
+ $md5->add($_);
+ }
+ close(FILE);
+ print $md5->b64digest, " $file\n";
+
+Or we can use the addfile method for more efficient reading of
+the file:
+
+ use Digest::MD5;
+
+ my $file = shift || "/etc/passwd";
+ open(FILE, $file) or die "Can't open '$file': $!";
+ binmode(FILE);
+
+ print Digest::MD5->new->addfile(*FILE)->hexdigest, " $file\n";
+
+Perl 5.8 support Unicode characters in strings. Since the MD5
+algorithm is only defined for strings of bytes, it can not be used on
+strings that contains chars with ordinal number above 255. The MD5
+functions and methods will croak if you try to feed them such input
+data:
+
+ use Digest::MD5 qw(md5_hex);
+
+ my $str = "abc\x{300}";
+ print md5_hex($str), "\n"; # croaks
+ # Wide character in subroutine entry
+
+What you can do is calculate the MD5 checksum of the UTF-8
+representation of such strings. This is achieved by filtering the
+string through encode_utf8() function:
+
+ use Digest::MD5 qw(md5_hex);
+ use Encode qw(encode_utf8);
+
+ my $str = "abc\x{300}";
+ print md5_hex(encode_utf8($str)), "\n";
+ # 8c2d46911f3f5a326455f0ed7a8ed3b3
+
+=head1 SEE ALSO
+
+L<Digest>,
+L<Digest::MD2>,
+L<Digest::SHA>,
+L<Digest::HMAC>
+
+L<md5sum(1)>
+
+RFC 1321
+
+http://en.wikipedia.org/wiki/MD5
+
+The paper "How to Break MD5 and Other Hash Functions" by Xiaoyun Wang
+and Hongbo Yu.
+
+=head1 COPYRIGHT
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1998-2003 Gisle Aas.
+ Copyright 1995-1996 Neil Winton.
+ Copyright 1991-1992 RSA Data Security, Inc.
+
+The MD5 algorithm is defined in RFC 1321. This implementation is
+derived from the reference C code in RFC 1321 which is covered by
+the following copyright statement:
+
+=over 4
+
+=item
+
+Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All
+rights reserved.
+
+License to copy and use this software is granted provided that it
+is identified as the "RSA Data Security, Inc. MD5 Message-Digest
+Algorithm" in all material mentioning or referencing this software
+or this function.
+
+License is also granted to make and use derivative works provided
+that such works are identified as "derived from the RSA Data
+Security, Inc. MD5 Message-Digest Algorithm" in all material
+mentioning or referencing the derived work.
+
+RSA Data Security, Inc. makes no representations concerning either
+the merchantability of this software or the suitability of this
+software for any particular purpose. It is provided "as is"
+without express or implied warranty of any kind.
+
+These notices must be retained in any copies of any part of this
+documentation and/or software.
+
+=back
+
+This copyright does not prohibit distribution of any version of Perl
+containing this extension under the terms of the GNU or Artistic
+licenses.
+
+=head1 AUTHORS
+
+The original C<MD5> interface was written by Neil Winton
+(C<N.Winton@axion.bt.co.uk>).
+
+The C<Digest::MD5> module is written by Gisle Aas <gisle@ActiveState.com>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Digest/SHA.pm b/Master/tlpkg/tlperl/lib/Digest/SHA.pm
new file mode 100644
index 00000000000..d57c16fce59
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest/SHA.pm
@@ -0,0 +1,669 @@
+package Digest::SHA;
+
+require 5.003000;
+
+use strict;
+use integer;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+$VERSION = '5.47';
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(
+ hmac_sha1 hmac_sha1_base64 hmac_sha1_hex
+ hmac_sha224 hmac_sha224_base64 hmac_sha224_hex
+ hmac_sha256 hmac_sha256_base64 hmac_sha256_hex
+ hmac_sha384 hmac_sha384_base64 hmac_sha384_hex
+ hmac_sha512 hmac_sha512_base64 hmac_sha512_hex
+ sha1 sha1_base64 sha1_hex
+ sha224 sha224_base64 sha224_hex
+ sha256 sha256_base64 sha256_hex
+ sha384 sha384_base64 sha384_hex
+ sha512 sha512_base64 sha512_hex);
+
+# If possible, inherit from Digest::base (which depends on MIME::Base64)
+
+*addfile = \&Addfile;
+
+eval {
+ require MIME::Base64;
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ *hexdigest = \&Hexdigest;
+ *b64digest = \&B64digest;
+}
+
+# The following routines aren't time-critical, so they can be left in Perl
+
+sub new {
+ my($class, $alg) = @_;
+ $alg =~ s/\D+//g if defined $alg;
+ if (ref($class)) { # instance method
+ unless (defined($alg) && ($alg != $class->algorithm)) {
+ sharewind($$class);
+ return($class);
+ }
+ shaclose($$class) if $$class;
+ $$class = shaopen($alg) || return;
+ return($class);
+ }
+ $alg = 1 unless defined $alg;
+ my $state = shaopen($alg) || return;
+ my $self = \$state;
+ bless($self, $class);
+ return($self);
+}
+
+sub DESTROY {
+ my $self = shift;
+ shaclose($$self) if $$self;
+}
+
+sub clone {
+ my $self = shift;
+ my $state = shadup($$self) || return;
+ my $copy = \$state;
+ bless($copy, ref($self));
+ return($copy);
+}
+
+*reset = \&new;
+
+sub add_bits {
+ my($self, $data, $nbits) = @_;
+ unless (defined $nbits) {
+ $nbits = length($data);
+ $data = pack("B*", $data);
+ }
+ shawrite($data, $nbits, $$self);
+ return($self);
+}
+
+sub _bail {
+ my $msg = shift;
+
+ require Carp;
+ Carp::croak("$msg: $!");
+}
+
+sub _addfile { # this is "addfile" from Digest::base 1.00
+ my ($self, $handle) = @_;
+
+ my $n;
+ my $buf = "";
+
+ while (($n = read($handle, $buf, 4096))) {
+ $self->add($buf);
+ }
+ _bail("Read failed") unless defined $n;
+
+ $self;
+}
+
+sub Addfile {
+ my ($self, $file, $mode) = @_;
+
+ return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
+
+ $mode = defined($mode) ? $mode : "";
+ my ($binary, $portable) = map { $_ eq $mode } ("b", "p");
+ my $text = -T $file;
+
+ local *FH;
+ # protect any leading or trailing whitespace in $file;
+ # otherwise, 2-arg "open" will ignore them
+ $file =~ s#^(\s)#./$1#;
+ open(FH, "< $file\0") or _bail("Open failed");
+ binmode(FH) if $binary || $portable;
+
+ unless ($portable && $text) {
+ $self->_addfile(*FH);
+ close(FH);
+ return($self);
+ }
+
+ my ($n1, $n2);
+ my ($buf1, $buf2) = ("", "");
+
+ while (($n1 = read(FH, $buf1, 4096))) {
+ while (substr($buf1, -1) eq "\015") {
+ $n2 = read(FH, $buf2, 4096);
+ _bail("Read failed") unless defined $n2;
+ last unless $n2;
+ $buf1 .= $buf2;
+ }
+ $buf1 =~ s/\015?\015\012/\012/g; # DOS/Windows
+ $buf1 =~ s/\015/\012/g; # early MacOS
+ $self->add($buf1);
+ }
+ _bail("Read failed") unless defined $n1;
+ close(FH);
+
+ $self;
+}
+
+sub dump {
+ my $self = shift;
+ my $file = shift || "";
+
+ shadump($file, $$self) || return;
+ return($self);
+}
+
+sub load {
+ my $class = shift;
+ my $file = shift || "";
+ if (ref($class)) { # instance method
+ shaclose($$class) if $$class;
+ $$class = shaload($file) || return;
+ return($class);
+ }
+ my $state = shaload($file) || return;
+ my $self = \$state;
+ bless($self, $class);
+ return($self);
+}
+
+Digest::SHA->bootstrap($VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::SHA - Perl extension for SHA-1/224/256/384/512
+
+=head1 SYNOPSIS
+
+In programs:
+
+ # Functional interface
+
+ use Digest::SHA qw(sha1 sha1_hex sha1_base64 ...);
+
+ $digest = sha1($data);
+ $digest = sha1_hex($data);
+ $digest = sha1_base64($data);
+
+ $digest = sha256($data);
+ $digest = sha384_hex($data);
+ $digest = sha512_base64($data);
+
+ # Object-oriented
+
+ use Digest::SHA;
+
+ $sha = Digest::SHA->new($alg);
+
+ $sha->add($data); # feed data into stream
+
+ $sha->addfile(*F);
+ $sha->addfile($filename);
+
+ $sha->add_bits($bits);
+ $sha->add_bits($data, $nbits);
+
+ $sha_copy = $sha->clone; # if needed, make copy of
+ $sha->dump($file); # current digest state,
+ $sha->load($file); # or save it on disk
+
+ $digest = $sha->digest; # compute digest
+ $digest = $sha->hexdigest;
+ $digest = $sha->b64digest;
+
+From the command line:
+
+ $ shasum files
+
+ $ shasum --help
+
+=head1 SYNOPSIS (HMAC-SHA)
+
+ # Functional interface only
+
+ use Digest::SHA qw(hmac_sha1 hmac_sha1_hex ...);
+
+ $digest = hmac_sha1($data, $key);
+ $digest = hmac_sha224_hex($data, $key);
+ $digest = hmac_sha256_base64($data, $key);
+
+=head1 ABSTRACT
+
+Digest::SHA is a complete implementation of the NIST Secure Hash
+Standard. It gives Perl programmers a convenient way to calculate
+SHA-1, SHA-224, SHA-256, SHA-384, and SHA-512 message digests.
+The module can handle all types of input, including partial-byte
+data.
+
+=head1 DESCRIPTION
+
+Digest::SHA is written in C for speed. If your platform lacks a
+C compiler, you can install the functionally equivalent (but much
+slower) L<Digest::SHA::PurePerl> module.
+
+The programming interface is easy to use: it's the same one found
+in CPAN's L<Digest> module. So, if your applications currently
+use L<Digest::MD5> and you'd prefer the stronger security of SHA,
+it's a simple matter to convert them.
+
+The interface provides two ways to calculate digests: all-at-once,
+or in stages. To illustrate, the following short program computes
+the SHA-256 digest of "hello world" using each approach:
+
+ use Digest::SHA qw(sha256_hex);
+
+ $data = "hello world";
+ @frags = split(//, $data);
+
+ # all-at-once (Functional style)
+ $digest1 = sha256_hex($data);
+
+ # in-stages (OOP style)
+ $state = Digest::SHA->new(256);
+ for (@frags) { $state->add($_) }
+ $digest2 = $state->hexdigest;
+
+ print $digest1 eq $digest2 ?
+ "whew!\n" : "oops!\n";
+
+To calculate the digest of an n-bit message where I<n> is not a
+multiple of 8, use the I<add_bits()> method. For example, consider
+the 446-bit message consisting of the bit-string "110" repeated
+148 times, followed by "11". Here's how to display its SHA-1
+digest:
+
+ use Digest::SHA;
+ $bits = "110" x 148 . "11";
+ $sha = Digest::SHA->new(1)->add_bits($bits);
+ print $sha->hexdigest, "\n";
+
+Note that for larger bit-strings, it's more efficient to use the
+two-argument version I<add_bits($data, $nbits)>, where I<$data> is
+in the customary packed binary format used for Perl strings.
+
+The module also lets you save intermediate SHA states to disk, or
+display them on standard output. The I<dump()> method generates
+portable, human-readable text describing the current state of
+computation. You can subsequently retrieve the file with I<load()>
+to resume where the calculation left off.
+
+To see what a state description looks like, just run the following:
+
+ use Digest::SHA;
+ Digest::SHA->new->add("Shaw" x 1962)->dump;
+
+As an added convenience, the Digest::SHA module offers routines to
+calculate keyed hashes using the HMAC-SHA-1/224/256/384/512
+algorithms. These services exist in functional form only, and
+mimic the style and behavior of the I<sha()>, I<sha_hex()>, and
+I<sha_base64()> functions.
+
+ # Test vector from draft-ietf-ipsec-ciph-sha-256-01.txt
+
+ use Digest::SHA qw(hmac_sha256_hex);
+ print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n";
+
+=head1 NIST STATEMENT ON SHA-1
+
+I<NIST was recently informed that researchers had discovered a way
+to "break" the current Federal Information Processing Standard SHA-1
+algorithm, which has been in effect since 1994. The researchers
+have not yet published their complete results, so NIST has not
+confirmed these findings. However, the researchers are a reputable
+research team with expertise in this area.>
+
+I<Due to advances in computing power, NIST already planned to phase
+out SHA-1 in favor of the larger and stronger hash functions (SHA-224,
+SHA-256, SHA-384 and SHA-512) by 2010. New developments should use
+the larger and stronger hash functions.>
+
+ref. L<http://www.csrc.nist.gov/pki/HashWorkshop/NIST%20Statement/Burr_Mar2005.html>
+
+=head1 PADDING OF BASE64 DIGESTS
+
+By convention, CPAN Digest modules do B<not> pad their Base64 output.
+Problems can occur when feeding such digests to other software that
+expects properly padded Base64 encodings.
+
+For the time being, any necessary padding must be done by the user.
+Fortunately, this is a simple operation: if the length of a Base64-encoded
+digest isn't a multiple of 4, simply append "=" characters to the end
+of the digest until it is:
+
+ while (length($b64_digest) % 4) {
+ $b64_digest .= '=';
+ }
+
+To illustrate, I<sha256_base64("abc")> is computed to be
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0
+
+which has a length of 43. So, the properly padded version is
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0=
+
+=head1 EXPORT
+
+None by default.
+
+=head1 EXPORTABLE FUNCTIONS
+
+Provided your C compiler supports a 64-bit type (e.g. the I<long
+long> of C99, or I<__int64> used by Microsoft C/C++), all of these
+functions will be available for use. Otherwise, you won't be able
+to perform the SHA-384 and SHA-512 transforms, both of which require
+64-bit operations.
+
+I<Functional style>
+
+=over 4
+
+=item B<sha1($data, ...)>
+
+=item B<sha224($data, ...)>
+
+=item B<sha256($data, ...)>
+
+=item B<sha384($data, ...)>
+
+=item B<sha512($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a binary string.
+
+=item B<sha1_hex($data, ...)>
+
+=item B<sha224_hex($data, ...)>
+
+=item B<sha256_hex($data, ...)>
+
+=item B<sha384_hex($data, ...)>
+
+=item B<sha512_hex($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
+
+=item B<sha1_base64($data, ...)>
+
+=item B<sha224_base64($data, ...)>
+
+=item B<sha256_base64($data, ...)>
+
+=item B<sha384_base64($data, ...)>
+
+=item B<sha512_base64($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a Base64 string.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<OOP style>
+
+=over 4
+
+=item B<new($alg)>
+
+Returns a new Digest::SHA object. Allowed values for I<$alg> are
+1, 224, 256, 384, or 512. It's also possible to use common string
+representations of the algorithm (e.g. "sha256", "SHA-384"). If
+the argument is missing, SHA-1 will be used by default.
+
+Invoking I<new> as an instance method will not create a new object;
+instead, it will simply reset the object to the initial state
+associated with I<$alg>. If the argument is missing, the object
+will continue using the same algorithm that was selected at creation.
+
+=item B<reset($alg)>
+
+This method has exactly the same effect as I<new($alg)>. In fact,
+I<reset> is just an alias for I<new>.
+
+=item B<hashsize>
+
+Returns the number of digest bits for this object. The values are
+160, 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384,
+and SHA-512, respectively.
+
+=item B<algorithm>
+
+Returns the digest algorithm for this object. The values are 1,
+224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384, and
+SHA-512, respectively.
+
+=item B<clone>
+
+Returns a duplicate copy of the object.
+
+=item B<add($data, ...)>
+
+Logically joins the arguments into a single string, and uses it to
+update the current digest state. In other words, the following
+statements have the same effect:
+
+ $sha->add("a"); $sha->add("b"); $sha->add("c");
+ $sha->add("a")->add("b")->add("c");
+ $sha->add("a", "b", "c");
+ $sha->add("abc");
+
+The return value is the updated object itself.
+
+=item B<add_bits($data, $nbits)>
+
+=item B<add_bits($bits)>
+
+Updates the current digest state by appending bits to it. The
+return value is the updated object itself.
+
+The first form causes the most-significant I<$nbits> of I<$data>
+to be appended to the stream. The I<$data> argument is in the
+customary binary format used for Perl strings.
+
+The second form takes an ASCII string of "0" and "1" characters as
+its argument. It's equivalent to
+
+ $sha->add_bits(pack("B*", $bits), length($bits));
+
+So, the following two statements do the same thing:
+
+ $sha->add_bits("111100001010");
+ $sha->add_bits("\xF0\xA0", 12);
+
+=item B<addfile(*FILE)>
+
+Reads from I<FILE> until EOF, and appends that data to the current
+state. The return value is the updated object itself.
+
+=item B<addfile($filename [, $mode])>
+
+Reads the contents of I<$filename>, and appends that data to the current
+state. The return value is the updated object itself.
+
+By default, I<$filename> is simply opened and read; no special modes
+or I/O disciplines are used. To change this, set the optional I<$mode>
+argument to one of the following values:
+
+ "b" read file in binary mode
+
+ "p" use portable mode
+
+The "p" mode is handy since it ensures that the digest value of
+I<$filename> will be the same when computed on different operating
+systems. It accomplishes this by internally translating all newlines in
+text files to UNIX format before calculating the digest. Binary files
+are read in raw mode with no translation whatsoever.
+
+For a fuller discussion of newline formats, refer to CPAN module
+L<File::LocalizeNewlines>. Its "universal line separator" regex forms
+the basis of I<addfile>'s portable mode processing.
+
+=item B<dump($filename)>
+
+Provides persistent storage of intermediate SHA states by writing
+a portable, human-readable representation of the current state to
+I<$filename>. If the argument is missing, or equal to the empty
+string, the state information will be written to STDOUT.
+
+=item B<load($filename)>
+
+Returns a Digest::SHA object representing the intermediate SHA
+state that was previously dumped to I<$filename>. If called as a
+class method, a new object is created; if called as an instance
+method, the object is reset to the state contained in I<$filename>.
+If the argument is missing, or equal to the empty string, the state
+information will be read from STDIN.
+
+=item B<digest>
+
+Returns the digest encoded as a binary string.
+
+Note that the I<digest> method is a read-once operation. Once it
+has been performed, the Digest::SHA object is automatically reset
+in preparation for calculating another digest value. Call
+I<$sha-E<gt>clone-E<gt>digest> if it's necessary to preserve the
+original digest state.
+
+=item B<hexdigest>
+
+Returns the digest encoded as a hexadecimal string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>hexdigest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+=item B<b64digest>
+
+Returns the digest encoded as a Base64 string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>b64digest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<HMAC-SHA-1/224/256/384/512>
+
+=over 4
+
+=item B<hmac_sha1($data, $key)>
+
+=item B<hmac_sha224($data, $key)>
+
+=item B<hmac_sha256($data, $key)>
+
+=item B<hmac_sha384($data, $key)>
+
+=item B<hmac_sha512($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a binary string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_hex($data, $key)>
+
+=item B<hmac_sha224_hex($data, $key)>
+
+=item B<hmac_sha256_hex($data, $key)>
+
+=item B<hmac_sha384_hex($data, $key)>
+
+=item B<hmac_sha512_hex($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a hexadecimal string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_base64($data, $key)>
+
+=item B<hmac_sha224_base64($data, $key)>
+
+=item B<hmac_sha256_base64($data, $key)>
+
+=item B<hmac_sha384_base64($data, $key)>
+
+=item B<hmac_sha512_base64($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a Base64 string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>, L<Digest::SHA::PurePerl>
+
+The Secure Hash Standard (FIPS PUB 180-2) can be found at:
+
+L<http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>
+
+The Keyed-Hash Message Authentication Code (HMAC):
+
+L<http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>
+
+=head1 AUTHOR
+
+ Mark Shelor <mshelor@cpan.org>
+
+=head1 ACKNOWLEDGMENTS
+
+The author is particularly grateful to
+
+ Gisle Aas
+ Chris Carey
+ Alexandr Ciornii
+ Jim Doble
+ Julius Duque
+ Jeffrey Friedl
+ Robert Gilmour
+ Brian Gladman
+ Adam Kennedy
+ Andy Lester
+ Alex Muntada
+ Steve Peters
+ Chris Skiscim
+ Martin Thurn
+ Gunnar Wolf
+ Adam Woodbury
+
+for their valuable comments and suggestions.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2003-2008 Mark Shelor
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+L<perlartistic>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Digest/SHA1.pm b/Master/tlpkg/tlperl/lib/Digest/SHA1.pm
new file mode 100644
index 00000000000..bd2647a1de3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest/SHA1.pm
@@ -0,0 +1,246 @@
+package Digest::SHA1;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = '2.13';
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(sha1 sha1_hex sha1_base64 sha1_transform);
+
+require DynaLoader;
+@ISA=qw(DynaLoader);
+
+eval {
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ my $err = $@;
+ *add_bits = sub { die $err };
+}
+
+Digest::SHA1->bootstrap($VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::SHA1 - Perl interface to the SHA-1 algorithm
+
+=head1 SYNOPSIS
+
+ # Functional style
+ use Digest::SHA1 qw(sha1 sha1_hex sha1_base64);
+
+ $digest = sha1($data);
+ $digest = sha1_hex($data);
+ $digest = sha1_base64($data);
+ $digest = sha1_transform($data);
+
+
+ # OO style
+ use Digest::SHA1;
+
+ $sha1 = Digest::SHA1->new;
+
+ $sha1->add($data);
+ $sha1->addfile(*FILE);
+
+ $sha1_copy = $sha1->clone;
+
+ $digest = $sha1->digest;
+ $digest = $sha1->hexdigest;
+ $digest = $sha1->b64digest;
+ $digest = $sha1->transform;
+
+=head1 DESCRIPTION
+
+The C<Digest::SHA1> module allows you to use the NIST SHA-1 message
+digest algorithm from within Perl programs. The algorithm takes as
+input a message of arbitrary length and produces as output a 160-bit
+"fingerprint" or "message digest" of the input.
+
+In 2005, security flaws were identified in SHA-1, namely that a possible
+mathematical weakness might exist, indicating that a stronger hash function
+would be desirable. The L<Digest::SHA> module implements the stronger
+algorithms in the SHA family.
+
+The C<Digest::SHA1> module provide a procedural interface for simple
+use, as well as an object oriented interface that can handle messages
+of arbitrary length and which can read files directly.
+
+=head1 FUNCTIONS
+
+The following functions can be exported from the C<Digest::SHA1>
+module. No functions are exported by default.
+
+=over 4
+
+=item sha1($data,...)
+
+This function will concatenate all arguments, calculate the SHA-1
+digest of this "message", and return it in binary form. The returned
+string will be 20 bytes long.
+
+The result of sha1("a", "b", "c") will be exactly the same as the
+result of sha1("abc").
+
+=item sha1_hex($data,...)
+
+Same as sha1(), but will return the digest in hexadecimal form. The
+length of the returned string will be 40 and it will only contain
+characters from this set: '0'..'9' and 'a'..'f'.
+
+=item sha1_base64($data,...)
+
+Same as sha1(), but will return the digest as a base64 encoded string.
+The length of the returned string will be 27 and it will only contain
+characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and
+'/'.
+
+Note that the base64 encoded string returned is not padded to be a
+multiple of 4 bytes long. If you want interoperability with other
+base64 encoded sha1 digests you might want to append the redundant
+string "=" to the result.
+
+=item sha1_transform($data)
+
+Implements the basic SHA1 transform on a 64 byte block. The $data
+argument and the returned $digest are in binary form. This algorithm
+is used in NIST FIPS 186-2
+
+=back
+
+=head1 METHODS
+
+The object oriented interface to C<Digest::SHA1> is described in this
+section. After a C<Digest::SHA1> object has been created, you will add
+data to it and finally ask for the digest in a suitable format. A
+single object can be used to calculate multiple digests.
+
+The following methods are provided:
+
+=over 4
+
+=item $sha1 = Digest::SHA1->new
+
+The constructor returns a new C<Digest::SHA1> object which encapsulate
+the state of the SHA-1 message-digest algorithm.
+
+If called as an instance method (i.e. $sha1->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.
+
+=item $sha1->reset
+
+This is just an alias for $sha1->new.
+
+=item $sha1->clone
+
+This a copy of the $sha1 object. It is useful when you do not want to
+destroy the digests state, but need an intermediate value of the
+digest, e.g. when calculating digests iteratively on a continuous data
+stream. Example:
+
+ my $sha1 = Digest::SHA1->new;
+ while (<>) {
+ $sha1->add($_);
+ print "Line $.: ", $sha1->clone->hexdigest, "\n";
+ }
+
+=item $sha1->add($data,...)
+
+The $data provided as argument are appended to the message we
+calculate the digest for. The return value is the $sha1 object itself.
+
+All these lines will have the same effect on the state of the $sha1
+object:
+
+ $sha1->add("a"); $sha1->add("b"); $sha1->add("c");
+ $sha1->add("a")->add("b")->add("c");
+ $sha1->add("a", "b", "c");
+ $sha1->add("abc");
+
+=item $sha1->addfile($io_handle)
+
+The $io_handle will be read until EOF and its content appended to the
+message we calculate the digest for. The return value is the $sha1
+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 $sha1
+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 $sha1 object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+C<binmode> before you pass it as argument to the addfile() method.
+
+=item $sha1->add_bits($data, $nbits)
+
+=item $sha1->add_bits($bitstring)
+
+This implementation of SHA-1 only supports byte oriented input so you
+might only add bits as multiples of 8. If you need bit level support
+please consider using the C<Digest::SHA> module instead. The
+add_bits() method is provided here for compatibility with other digest
+implementations. See L<Digest> for description of the arguments that
+add_bits() take.
+
+=item $sha1->digest
+
+Return the binary digest for the message. The returned string will be
+20 bytes long.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the C<Digest::SHA1>
+object is automatically C<reset> and can be used to calculate another
+digest value. Call $sha1->clone->digest if you want to calculate the
+digest without reseting the digest state.
+
+=item $sha1->hexdigest
+
+Same as $sha1->digest, but will return the digest in hexadecimal
+form. The length of the returned string will be 40 and it will only
+contain characters from this set: '0'..'9' and 'a'..'f'.
+
+=item $sha1->b64digest
+
+Same as $sha1->digest, but will return the digest as a base64 encoded
+string. The length of the returned string will be 27 and it will only
+contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+'
+and '/'.
+
+
+The base64 encoded string returned is not padded to be a multiple of 4
+bytes long. If you want interoperability with other base64 encoded
+SHA-1 digests you might want to append the string "=" to the result.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>, L<Digest::HMAC_SHA1>, L<Digest::SHA>, L<Digest::MD5>
+
+http://www.itl.nist.gov/fipspubs/fip180-1.htm
+
+http://en.wikipedia.org/wiki/SHA_hash_functions
+
+=head1 COPYRIGHT
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1999-2004 Gisle Aas.
+ Copyright 1997 Uwe Hollerbach.
+
+=head1 AUTHORS
+
+Peter C. Gutmann,
+Uwe Hollerbach <uh@alumni.caltech.edu>,
+Gisle Aas <gisle@aas.no>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Digest/base.pm b/Master/tlpkg/tlperl/lib/Digest/base.pm
new file mode 100644
index 00000000000..b2844ba3400
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest/base.pm
@@ -0,0 +1,100 @@
+package Digest::base;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "1.16";
+
+# subclass is supposed to implement at least these
+sub new;
+sub clone;
+sub add;
+sub digest;
+
+sub reset {
+ my $self = shift;
+ $self->new(@_); # ugly
+}
+
+sub addfile {
+ my ($self, $handle) = @_;
+
+ my $n;
+ my $buf = "";
+
+ while (($n = read($handle, $buf, 4*1024))) {
+ $self->add($buf);
+ }
+ unless (defined $n) {
+ require Carp;
+ Carp::croak("Read failed: $!");
+ }
+
+ $self;
+}
+
+sub add_bits {
+ my $self = shift;
+ my $bits;
+ my $nbits;
+ if (@_ == 1) {
+ my $arg = shift;
+ $bits = pack("B*", $arg);
+ $nbits = length($arg);
+ }
+ else {
+ ($bits, $nbits) = @_;
+ }
+ if (($nbits % 8) != 0) {
+ require Carp;
+ Carp::croak("Number of bits must be multiple of 8 for this algorithm");
+ }
+ return $self->add(substr($bits, 0, $nbits/8));
+}
+
+sub hexdigest {
+ my $self = shift;
+ return unpack("H*", $self->digest(@_));
+}
+
+sub b64digest {
+ my $self = shift;
+ require MIME::Base64;
+ my $b64 = MIME::Base64::encode($self->digest(@_), "");
+ $b64 =~ s/=+$//;
+ return $b64;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::base - Digest base class
+
+=head1 SYNOPSIS
+
+ package Digest::Foo;
+ use base 'Digest::base';
+
+=head1 DESCRIPTION
+
+The C<Digest::base> class provide implementations of the methods
+C<addfile> and C<add_bits> in terms of C<add>, and of the methods
+C<hexdigest> and C<b64digest> in terms of C<digest>.
+
+Digest implementations might want to inherit from this class to get
+this implementations of the alternative I<add> and I<digest> methods.
+A minimal subclass needs to implement the following methods by itself:
+
+ new
+ clone
+ add
+ digest
+
+The arguments and expected behaviour of these methods are described in
+L<Digest>.
+
+=head1 SEE ALSO
+
+L<Digest>
diff --git a/Master/tlpkg/tlperl/lib/Digest/file.pm b/Master/tlpkg/tlperl/lib/Digest/file.pm
new file mode 100644
index 00000000000..3b86e63503a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest/file.pm
@@ -0,0 +1,85 @@
+package Digest::file;
+
+use strict;
+
+use Exporter ();
+use Carp qw(croak);
+use Digest ();
+
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = "1.16";
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(digest_file_ctx digest_file digest_file_hex digest_file_base64);
+
+sub digest_file_ctx {
+ my $file = shift;
+ croak("No digest algorithm specified") unless @_;
+ local *F;
+ open(F, "<", $file) || croak("Can't open '$file': $!");
+ binmode(F);
+ my $ctx = Digest->new(@_);
+ $ctx->addfile(*F);
+ close(F);
+ return $ctx;
+}
+
+sub digest_file {
+ digest_file_ctx(@_)->digest;
+}
+
+sub digest_file_hex {
+ digest_file_ctx(@_)->hexdigest;
+}
+
+sub digest_file_base64 {
+ digest_file_ctx(@_)->b64digest;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest::file - Calculate digests of files
+
+=head1 SYNOPSIS
+
+ # Poor mans "md5sum" command
+ use Digest::file qw(digest_file_hex);
+ for (@ARGV) {
+ print digest_file_hex($_, "MD5"), " $_\n";
+ }
+
+=head1 DESCRIPTION
+
+This module provide 3 convenience functions to calculate the digest
+of files. The following functions are provided:
+
+=over
+
+=item digest_file( $file, $algorithm, [$arg,...] )
+
+This function will calculate and return the binary digest of the bytes
+of the given file. The function will croak if it fails to open or
+read the file.
+
+The $algorithm is a string like "MD2", "MD5", "SHA-1", "SHA-512".
+Additional arguments are passed to the constructor for the
+implementation of the given algorithm.
+
+=item digest_file_hex( $file, $algorithm, [$arg,...] )
+
+Same as digest_file(), but return the digest in hex form.
+
+=item digest_file_base64( $file, $algorithm, [$arg,...] )
+
+Same as digest_file(), but return the digest as a base64 encoded
+string.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>
diff --git a/Master/tlpkg/tlperl/lib/Exporter/Heavy.pm b/Master/tlpkg/tlperl/lib/Exporter/Heavy.pm
new file mode 100644
index 00000000000..724028a2b1a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Exporter/Heavy.pm
@@ -0,0 +1,248 @@
+package Exporter::Heavy;
+
+use strict;
+no strict 'refs';
+
+# On one line so MakeMaker will see it.
+require Exporter; our $VERSION = $Exporter::VERSION;
+
+=head1 NAME
+
+Exporter::Heavy - Exporter guts
+
+=head1 SYNOPSIS
+
+(internal use only)
+
+=head1 DESCRIPTION
+
+No user-serviceable parts inside.
+
+=cut
+
+#
+# We go to a lot of trouble not to 'require Carp' at file scope,
+# because Carp requires Exporter, and something has to give.
+#
+
+sub _rebuild_cache {
+ my ($pkg, $exports, $cache) = @_;
+ s/^&// foreach @$exports;
+ @{$cache}{@$exports} = (1) x @$exports;
+ my $ok = \@{"${pkg}::EXPORT_OK"};
+ if (@$ok) {
+ s/^&// foreach @$ok;
+ @{$cache}{@$ok} = (1) x @$ok;
+ }
+}
+
+sub heavy_export {
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ }
+ else {
+ warn $text;
+ }
+ };
+ local $SIG{__DIE__} = sub {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
+ if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
+ };
+
+ my($pkg, $callpkg, @imports) = @_;
+ my($type, $sym, $cache_is_current, $oops);
+ my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
+ $Exporter::Cache{$pkg} ||= {});
+
+ if (@imports) {
+ if (!%$export_cache) {
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (grep m{^[/!:]}, @imports) {
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ my($remove, $spec, @names, @allexports);
+ # negated first item implies starting with default set:
+ unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
+ foreach $spec (@imports){
+ $remove = $spec =~ s/^!//;
+
+ if ($spec =~ s/^://){
+ if ($spec eq 'DEFAULT'){
+ @names = @$exports;
+ }
+ elsif ($tagdata = $tagsref->{$spec}) {
+ @names = @$tagdata;
+ }
+ else {
+ warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
+ ++$oops;
+ next;
+ }
+ }
+ elsif ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @allexports = keys %$export_cache unless @allexports; # only do keys once
+ @names = grep(/$patn/, @allexports); # not anchored by default
+ }
+ else {
+ @names = ($spec); # is a normal symbol name
+ }
+
+ warn "Import ".($remove ? "del":"add").": @names "
+ if $Exporter::Verbose;
+
+ if ($remove) {
+ foreach $sym (@names) { delete $imports{$sym} }
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
+ my @carp;
+ foreach $sym (@imports) {
+ if (!$export_cache->{$sym}) {
+ if ($sym =~ m/^\d/) {
+ $pkg->VERSION($sym); # inherit from UNIVERSAL
+ # If the version number was the only thing specified
+ # then we should act as if nothing was specified:
+ if (@imports == 1) {
+ @imports = @$exports;
+ last;
+ }
+ # We need a way to emulate 'use Foo ()' but still
+ # allow an easy version check: "use Foo 1.23, ''";
+ if (@imports == 2 and !$imports[1]) {
+ @imports = ();
+ last;
+ }
+ } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
+ # Last chance - see if they've updated EXPORT_OK since we
+ # cached it.
+
+ unless ($cache_is_current) {
+ %$export_cache = ();
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (!$export_cache->{$sym}) {
+ # accumulate the non-exports
+ push @carp,
+ qq["$sym" is not exported by the $pkg module\n];
+ $oops++;
+ }
+ }
+ }
+ }
+ if ($oops) {
+ require Carp;
+ Carp::croak("@{carp}Can't continue after import errors");
+ }
+ }
+ else {
+ @imports = @$exports;
+ }
+
+ my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
+ $Exporter::FailCache{$pkg} ||= {});
+
+ if (@$fail) {
+ if (!%$fail_cache) {
+ # Build cache of symbols. Optimise the lookup by adding
+ # barewords twice... both with and without a leading &.
+ # (Technique could be applied to $export_cache at cost of memory)
+ my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
+ warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
+ @{$fail_cache}{@expanded} = (1) x @expanded;
+ }
+ my @failed;
+ foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
+ if (@failed) {
+ @failed = $pkg->export_fail(@failed);
+ foreach $sym (@failed) {
+ require Carp;
+ Carp::carp(qq["$sym" is not implemented by the $pkg module ],
+ "on this architecture");
+ }
+ if (@failed) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
+ }
+ }
+
+ warn "Importing into $callpkg from $pkg: ",
+ join(", ",sort @imports) if $Exporter::Verbose;
+
+ foreach $sym (@imports) {
+ # shortcut for the common case of no type character
+ (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
+ unless $sym =~ s/^(\W)//;
+ $type = $1;
+ no warnings 'once';
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
+ do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
+ }
+}
+
+sub heavy_export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # XXX redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+# Utility functions
+
+sub _push_tags {
+ my($pkg, $var, $syms) = @_;
+ my @nontag = ();
+ my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::$var"},
+ map { $export_tags->{$_} ? @{$export_tags->{$_}}
+ : scalar(push(@nontag,$_),$_) }
+ (@$syms) ? @$syms : keys %$export_tags);
+ if (@nontag and $^W) {
+ # This may change to a die one day
+ require Carp;
+ Carp::carp(join(", ", @nontag)." are not tags of $pkg");
+ }
+}
+
+sub heavy_require_version {
+ my($self, $wanted) = @_;
+ my $pkg = ref $self || $self;
+ return ${pkg}->VERSION($wanted);
+}
+
+sub heavy_export_tags {
+ _push_tags((caller)[0], "EXPORT", \@_);
+}
+
+sub heavy_export_ok_tags {
+ _push_tags((caller)[0], "EXPORT_OK", \@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Basename.pm b/Master/tlpkg/tlperl/lib/File/Basename.pm
new file mode 100644
index 00000000000..d842844daf1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Basename.pm
@@ -0,0 +1,402 @@
+=head1 NAME
+
+File::Basename - Parse file paths into directory, filename and suffix.
+
+=head1 SYNOPSIS
+
+ use File::Basename;
+
+ ($name,$path,$suffix) = fileparse($fullname,@suffixlist);
+ $name = fileparse($fullname,@suffixlist);
+
+ $basename = basename($fullname,@suffixlist);
+ $dirname = dirname($fullname);
+
+
+=head1 DESCRIPTION
+
+These routines allow you to parse file paths into their directory, filename
+and suffix.
+
+B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
+quirks, of the shell and C functions of the same name. See each
+function's documentation for details. If your concern is just parsing
+paths it is safer to use L<File::Spec>'s C<splitpath()> and
+C<splitdir()> methods.
+
+It is guaranteed that
+
+ # Where $path_separator is / for Unix, \ for Windows, etc...
+ dirname($path) . $path_separator . basename($path);
+
+is equivalent to the original path for all systems but VMS.
+
+
+=cut
+
+
+package File::Basename;
+
+# File::Basename is used during the Perl build, when the re extension may
+# not be available, but we only actually need it if running under tainting.
+BEGIN {
+ if (${^TAINT}) {
+ require re;
+ re->import('taint');
+ }
+}
+
+
+use strict;
+use 5.006;
+use warnings;
+our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
+$VERSION = "2.78";
+
+fileparse_set_fstype($^O);
+
+
+=over 4
+
+=item C<fileparse>
+X<fileparse>
+
+ my($filename, $directories, $suffix) = fileparse($path);
+ my($filename, $directories, $suffix) = fileparse($path, @suffixes);
+ my $filename = fileparse($path, @suffixes);
+
+The C<fileparse()> routine divides a file path into its $directories, $filename
+and (optionally) the filename $suffix.
+
+$directories contains everything up to and including the last
+directory separator in the $path including the volume (if applicable).
+The remainder of the $path is the $filename.
+
+ # On Unix returns ("baz", "/foo/bar/", "")
+ fileparse("/foo/bar/baz");
+
+ # On Windows returns ("baz", "C:\foo\bar\", "")
+ fileparse("C:\foo\bar\baz");
+
+ # On Unix returns ("", "/foo/bar/baz/", "")
+ fileparse("/foo/bar/baz/");
+
+If @suffixes are given each element is a pattern (either a string or a
+C<qr//>) matched against the end of the $filename. The matching
+portion is removed and becomes the $suffix.
+
+ # 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
+matching for suffix removal is performed case-insensitively, since
+those systems are not case-sensitive when opening existing files.
+
+You are guaranteed that C<$directories . $filename . $suffix> will
+denote the same location as the original $path.
+
+=cut
+
+
+sub fileparse {
+ my($fullname,@suffices) = @_;
+
+ unless (defined $fullname) {
+ require Carp;
+ Carp::croak("fileparse(): need a valid pathname");
+ }
+
+ my $orig_type = '';
+ my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
+
+ my($taint) = substr($fullname,0,0); # Is $fullname tainted?
+
+ if ($type eq "VMS" and $fullname =~ m{/} ) {
+ # We're doing Unix emulation
+ $orig_type = $type;
+ $type = 'Unix';
+ }
+
+ my($dirpath, $basename);
+
+ if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
+ ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
+ $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
+ }
+ elsif ($type eq "OS2") {
+ ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
+ $dirpath = './' unless $dirpath; # Can't be 0
+ $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
+ }
+ elsif ($type eq "MacOS") {
+ ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
+ $dirpath = ':' unless $dirpath;
+ }
+ elsif ($type eq "AmigaOS") {
+ ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
+ $dirpath = './' unless $dirpath;
+ }
+ elsif ($type eq 'VMS' ) {
+ ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
+ $dirpath ||= ''; # should always be defined
+ }
+ else { # Default to Unix semantics.
+ ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
+ if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
+ # dev:[000000] is top of VMS tree, similar to Unix '/'
+ # so strip it off and treat the rest as "normal"
+ my $devspec = $1;
+ my $remainder = $3;
+ ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
+ $dirpath ||= ''; # should always be defined
+ $dirpath = $devspec.$dirpath;
+ }
+ $dirpath = './' unless $dirpath;
+ }
+
+
+ my $tail = '';
+ my $suffix = '';
+ if (@suffices) {
+ foreach $suffix (@suffices) {
+ my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
+ if ($basename =~ s/$pat//s) {
+ $taint .= substr($suffix,0,0);
+ $tail = $1 . $tail;
+ }
+ }
+ }
+
+ # Ensure taint is propgated from the path to its pieces.
+ $tail .= $taint;
+ wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
+ : ($basename .= $taint);
+}
+
+
+
+=item C<basename>
+X<basename> X<filename>
+
+ my $filename = basename($path);
+ my $filename = basename($path, @suffixes);
+
+This function is provided for compatibility with the Unix shell command
+C<basename(1)>. It does B<NOT> always return the file name portion of a
+path as you might expect. To be safe, if you want the file name portion of
+a path use C<fileparse()>.
+
+C<basename()> returns the last level of a filepath even if the last
+level is clearly directory. In effect, it is acting like C<pop()> for
+paths. This differs from C<fileparse()>'s behaviour.
+
+ # Both return "bar"
+ basename("/foo/bar");
+ basename("/foo/bar/");
+
+@suffixes work as in C<fileparse()> except all regex metacharacters are
+quoted.
+
+ # These two function calls are equivalent.
+ my $filename = basename("/foo/bar/baz.txt", ".txt");
+ my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
+
+Also note that in order to be compatible with the shell command,
+C<basename()> does not strip off a suffix if it is identical to the
+remaining characters in the filename.
+
+=cut
+
+
+sub basename {
+ my($path) = shift;
+
+ # From BSD basename(1)
+ # The basename utility deletes any prefix ending with the last slash `/'
+ # character present in string (after first stripping trailing slashes)
+ _strip_trailing_sep($path);
+
+ my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
+
+ # From BSD basename(1)
+ # The suffix is not stripped if it is identical to the remaining
+ # characters in string.
+ if( length $suffix and !length $basename ) {
+ $basename = $suffix;
+ }
+
+ # Ensure that basename '/' == '/'
+ if( !length $basename ) {
+ $basename = $dirname;
+ }
+
+ return $basename;
+}
+
+
+
+=item C<dirname>
+X<dirname>
+
+This function is provided for compatibility with the Unix shell
+command C<dirname(1)> and has inherited some of its quirks. In spite of
+its name it does B<NOT> always return the directory name as you might
+expect. To be safe, if you want the directory name of a path use
+C<fileparse()>.
+
+Only on VMS (where there is no ambiguity between the file and directory
+portions of a path) and AmigaOS (possibly due to an implementation quirk in
+this module) does C<dirname()> work like C<fileparse($path)>, returning just the
+$directories.
+
+ # On VMS and AmigaOS
+ my $directories = dirname($path);
+
+When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
+which is subtly different from how C<fileparse()> works. It returns all but
+the last level of a file path even if the last level is clearly a directory.
+In effect, it is not returning the directory portion but simply the path one
+level up acting like C<chop()> for file paths.
+
+Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
+its returned path.
+
+ # returns /foo/bar. fileparse() would return /foo/bar/
+ dirname("/foo/bar/baz");
+
+ # also returns /foo/bar despite the fact that baz is clearly a
+ # directory. fileparse() would return /foo/bar/baz/
+ dirname("/foo/bar/baz/");
+
+ # returns '.'. fileparse() would return 'foo/'
+ dirname("foo/");
+
+Under VMS, if there is no directory information in the $path, then the
+current default device and directory is used.
+
+=cut
+
+
+sub dirname {
+ my $path = shift;
+
+ my($type) = $Fileparse_fstype;
+
+ if( $type eq 'VMS' and $path =~ m{/} ) {
+ # Parse as Unix
+ local($File::Basename::Fileparse_fstype) = '';
+ return dirname($path);
+ }
+
+ my($basename, $dirname) = fileparse($path);
+
+ if ($type eq 'VMS') {
+ $dirname ||= $ENV{DEFAULT};
+ }
+ elsif ($type eq 'MacOS') {
+ if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
+ _strip_trailing_sep($dirname);
+ ($basename,$dirname) = fileparse $dirname;
+ }
+ $dirname .= ":" unless $dirname =~ /:\z/;
+ }
+ elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
+ _strip_trailing_sep($dirname);
+ unless( length($basename) ) {
+ ($basename,$dirname) = fileparse $dirname;
+ _strip_trailing_sep($dirname);
+ }
+ }
+ elsif ($type eq 'AmigaOS') {
+ if ( $dirname =~ /:\z/) { return $dirname }
+ chop $dirname;
+ $dirname =~ s{[^:/]+\z}{} unless length($basename);
+ }
+ else {
+ _strip_trailing_sep($dirname);
+ unless( length($basename) ) {
+ ($basename,$dirname) = fileparse $dirname;
+ _strip_trailing_sep($dirname);
+ }
+ }
+
+ $dirname;
+}
+
+
+# Strip the trailing path separator.
+sub _strip_trailing_sep {
+ my $type = $Fileparse_fstype;
+
+ if ($type eq 'MacOS') {
+ $_[0] =~ s/([^:]):\z/$1/s;
+ }
+ elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
+ $_[0] =~ s/([^:])[\\\/]*\z/$1/;
+ }
+ else {
+ $_[0] =~ s{(.)/*\z}{$1}s;
+ }
+}
+
+
+=item C<fileparse_set_fstype>
+X<filesystem>
+
+ my $type = fileparse_set_fstype();
+ my $previous_type = fileparse_set_fstype($type);
+
+Normally File::Basename will assume a file path type native to your current
+operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
+With this function you can override that assumption.
+
+Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
+"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
+"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is
+given "Unix" will be assumed.
+
+If you've selected VMS syntax, and the file specification you pass to
+one of these routines contains a "/", they assume you are using Unix
+emulation and apply the Unix syntax rules instead, for that function
+call only.
+
+=back
+
+=cut
+
+
+BEGIN {
+
+my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
+my @Types = (@Ignore_Case, qw(Unix));
+
+sub fileparse_set_fstype {
+ my $old = $Fileparse_fstype;
+
+ if (@_) {
+ my $new_type = shift;
+
+ $Fileparse_fstype = 'Unix'; # default
+ foreach my $type (@Types) {
+ $Fileparse_fstype = $type if $new_type =~ /^$type/i;
+ }
+
+ $Fileparse_igncase =
+ (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
+ }
+
+ return $old;
+}
+
+}
+
+
+1;
+
+
+=head1 SEE ALSO
+
+L<dirname(1)>, L<basename(1)>, L<File::Spec>
diff --git a/Master/tlpkg/tlperl/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm
new file mode 100644
index 00000000000..d7948f2385f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/CheckTree.pm
@@ -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@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;
diff --git a/Master/tlpkg/tlperl/lib/File/Compare.pm b/Master/tlpkg/tlperl/lib/File/Compare.pm
new file mode 100644
index 00000000000..05e1c41d211
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Compare.pm
@@ -0,0 +1,182 @@
+package File::Compare;
+
+use 5.006;
+use strict;
+use warnings;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big);
+
+require Exporter;
+
+$VERSION = '1.1006';
+@ISA = qw(Exporter);
+@EXPORT = qw(compare);
+@EXPORT_OK = qw(cmp compare_text);
+
+$Too_Big = 1024 * 1024 * 2;
+
+sub croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub compare {
+ croak("Usage: compare( file1, file2 [, buffersize]) ")
+ unless(@_ == 2 || @_ == 3);
+
+ my ($from,$to,$size) = @_;
+ my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
+
+ my ($fromsize,$closefrom,$closeto);
+ local (*FROM, *TO);
+
+ croak("from undefined") unless (defined $from);
+ croak("to undefined") unless (defined $to);
+
+ if (ref($from) &&
+ (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
+ *FROM = *$from;
+ } elsif (ref(\$from) eq 'GLOB') {
+ *FROM = $from;
+ } else {
+ open(FROM,"<",$from) or goto fail_open1;
+ unless ($text_mode) {
+ binmode FROM;
+ $fromsize = -s FROM;
+ }
+ $closefrom = 1;
+ }
+
+ if (ref($to) &&
+ (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
+ *TO = *$to;
+ } elsif (ref(\$to) eq 'GLOB') {
+ *TO = $to;
+ } else {
+ open(TO,"<",$to) or goto fail_open2;
+ binmode TO unless $text_mode;
+ $closeto = 1;
+ }
+
+ if (!$text_mode && $closefrom && $closeto) {
+ # If both are opened files we know they differ if their size differ
+ goto fail_inner if $fromsize != -s TO;
+ }
+
+ if ($text_mode) {
+ local $/ = "\n";
+ my ($fline,$tline);
+ while (defined($fline = <FROM>)) {
+ goto fail_inner unless defined($tline = <TO>);
+ if (ref $size) {
+ # $size contains ref to comparison function
+ goto fail_inner if &$size($fline, $tline);
+ } else {
+ goto fail_inner if $fline ne $tline;
+ }
+ }
+ goto fail_inner if defined($tline = <TO>);
+ }
+ else {
+ unless (defined($size) && $size > 0) {
+ $size = $fromsize || -s TO || 0;
+ $size = 1024 if $size < 512;
+ $size = $Too_Big if $size > $Too_Big;
+ }
+
+ my ($fr,$tr,$fbuf,$tbuf);
+ $fbuf = $tbuf = '';
+ while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
+ unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
+ goto fail_inner;
+ }
+ }
+ goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
+ }
+
+ close(TO) || goto fail_open2 if $closeto;
+ close(FROM) || goto fail_open1 if $closefrom;
+
+ return 0;
+
+ # All of these contortions try to preserve error messages...
+ fail_inner:
+ close(TO) || goto fail_open2 if $closeto;
+ close(FROM) || goto fail_open1 if $closefrom;
+
+ return 1;
+
+ fail_open2:
+ if ($closefrom) {
+ my $status = $!;
+ $! = 0;
+ close FROM;
+ $! = $status unless $!;
+ }
+ fail_open1:
+ return -1;
+}
+
+sub cmp;
+*cmp = \&compare;
+
+sub compare_text {
+ my ($from,$to,$cmp) = @_;
+ croak("Usage: compare_text( file1, file2 [, cmp-function])")
+ unless @_ == 2 || @_ == 3;
+ croak("Third arg to compare_text() function must be a code reference")
+ if @_ == 3 && ref($cmp) ne 'CODE';
+
+ # Using a negative buffer size puts compare into text_mode too
+ $cmp = -1 unless defined $cmp;
+ compare($from, $to, $cmp);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Compare - Compare files or filehandles
+
+=head1 SYNOPSIS
+
+ use File::Compare;
+
+ if (compare("file1","file2") == 0) {
+ print "They're equal\n";
+ }
+
+=head1 DESCRIPTION
+
+The File::Compare::compare function compares the contents of two
+sources, each of which can be a file or a file handle. It is exported
+from File::Compare by default.
+
+File::Compare::cmp is a synonym for File::Compare::compare. It is
+exported from File::Compare only by request.
+
+File::Compare::compare_text does a line by line comparison of the two
+files. It stops as soon as a difference is detected. compare_text()
+accepts an optional third argument: This must be a CODE reference to
+a line comparison function, which returns 0 when both lines are considered
+equal. For example:
+
+ compare_text($file1, $file2)
+
+is basically equivalent to
+
+ compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
+
+=head1 RETURN
+
+File::Compare::compare and its sibling functions return 0 if the files
+are equal, 1 if the files are unequal, or -1 if an error was encountered.
+
+=head1 AUTHOR
+
+File::Compare was written by Nick Ing-Simmons.
+Its original documentation was written by Chip Salzenberg.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm
new file mode 100644
index 00000000000..eed6a53195b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Copy.pm
@@ -0,0 +1,656 @@
+# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
+# source code has been placed in the public domain by the author.
+# Please be kind and preserve the documentation.
+#
+# Additions copyright 1996 by Charles Bailey. Permission is granted
+# to distribute the revised code under the same terms as Perl itself.
+
+package File::Copy;
+
+use 5.006;
+use strict;
+use warnings;
+use File::Spec;
+use Config;
+# During perl build, we need File::Copy but Scalar::Util might not be built yet
+# And then we need these games to avoid loading overload, as that will
+# confuse miniperl during the bootstrap of perl.
+my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
+our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
+sub copy;
+sub syscopy;
+sub cp;
+sub mv;
+
+$VERSION = '2.18';
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(copy move);
+@EXPORT_OK = qw(cp mv);
+
+$Too_Big = 1024 * 1024 * 2;
+
+sub croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub carp {
+ require Carp;
+ goto &Carp::carp;
+}
+
+my $macfiles;
+if ($^O eq 'MacOS') {
+ $macfiles = eval { require Mac::MoreFiles };
+ warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
+ if $@ && $^W;
+}
+
+# Look up the feature settings on VMS using VMS::Feature when available.
+
+my $use_vms_feature = 0;
+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;
+}
+
+
+sub _catname {
+ my($from, $to) = @_;
+ if (not defined &basename) {
+ require File::Basename;
+ import File::Basename 'basename';
+ }
+
+ if ($^O eq 'MacOS') {
+ # a partial dir name that's valid only in the cwd (e.g. 'tmp')
+ $to = ':' . $to if $to !~ /:/;
+ }
+
+ return File::Spec->catfile($to, basename($from));
+}
+
+# _eq($from, $to) tells whether $from and $to are identical
+sub _eq {
+ my ($from, $to) = map {
+ $Scalar_Util_loaded && Scalar::Util::blessed($_)
+ && overload::Method($_, q{""})
+ ? "$_"
+ : $_
+ } (@_);
+ return '' if ( (ref $from) xor (ref $to) );
+ return $from == $to if ref $from;
+ return $from eq $to;
+}
+
+sub copy {
+ croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
+ unless(@_ == 2 || @_ == 3);
+
+ my $from = shift;
+ my $to = shift;
+
+ my $size;
+ if (@_) {
+ $size = shift(@_) + 0;
+ croak("Bad buffer size for copy: $size\n") unless ($size > 0);
+ }
+
+ my $from_a_handle = (ref($from)
+ ? (ref($from) eq 'GLOB'
+ || UNIVERSAL::isa($from, 'GLOB')
+ || UNIVERSAL::isa($from, 'IO::Handle'))
+ : (ref(\$from) eq 'GLOB'));
+ my $to_a_handle = (ref($to)
+ ? (ref($to) eq 'GLOB'
+ || UNIVERSAL::isa($to, 'GLOB')
+ || UNIVERSAL::isa($to, 'IO::Handle'))
+ : (ref(\$to) eq 'GLOB'));
+
+ 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;
+ }
+
+ if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
+ !($^O eq 'MSWin32' || $^O eq 'os2')) {
+ my @fs = stat($from);
+ if (@fs) {
+ my @ts = stat($to);
+ if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
+ carp("'$from' and '$to' are identical (not copied)");
+ return 0;
+ }
+ }
+ }
+
+ if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
+ $to = _catname($from, $to);
+ }
+
+ 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 'MacOS')
+ && !($from_a_handle && $^O eq 'NetWare')
+ )
+ {
+ my $copy_to = $to;
+
+ if ($^O eq 'VMS' && -e $from) {
+
+ if (! -d $to && ! -d $from) {
+
+ my $vms_efs = _vms_efs();
+ my $unix_rpt = _vms_unix_rpt();
+ my $unix_mode = 0;
+ my $from_unix = 0;
+ $from_unix = 1 if ($from =~ /^\.\.?$/);
+ my $from_vms = 0;
+ $from_vms = 1 if ($from =~ m#[\[<\]]#);
+
+ # Need to know if we are in Unix mode.
+ if ($from_vms == $from_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $from_unix;
+ }
+
+ # VMS has sticky defaults on extensions, which means that
+ # if there is a null extension on the destination file, it
+ # will inherit the extension of the source file
+ # So add a '.' for a null extension.
+
+ # In unix_rpt mode, the trailing dot should not be added.
+
+ if ($vms_efs) {
+ $copy_to = $to;
+ } else {
+ $copy_to = VMS::Filespec::vmsify($to);
+ }
+ my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
+ $file = $file . '.'
+ unless (($file =~ /(?<!\^)\./) || $unix_rpt);
+ $copy_to = File::Spec->catpath($vol, $dirs, $file);
+
+ # Get rid of the old versions to be like UNIX
+ 1 while unlink $copy_to;
+ }
+ }
+
+ return syscopy($from, $copy_to) || 0;
+ }
+
+ my $closefrom = 0;
+ my $closeto = 0;
+ my ($status, $r, $buf);
+ local($\) = '';
+
+ my $from_h;
+ if ($from_a_handle) {
+ $from_h = $from;
+ } else {
+ open $from_h, "<", $from or goto fail_open1;
+ binmode $from_h or die "($!,$^E)";
+ $closefrom = 1;
+ }
+
+ # Seems most logical to do this here, in case future changes would want to
+ # make this croak for some reason.
+ unless (defined $size) {
+ $size = tied(*$from_h) ? 0 : -s $from_h || 0;
+ $size = 1024 if ($size < 512);
+ $size = $Too_Big if ($size > $Too_Big);
+ }
+
+ my $to_h;
+ if ($to_a_handle) {
+ $to_h = $to;
+ } else {
+ $to_h = \do { local *FH }; # XXX is this line obsolete?
+ open $to_h, ">", $to or goto fail_open2;
+ binmode $to_h or die "($!,$^E)";
+ $closeto = 1;
+ }
+
+ $! = 0;
+ for (;;) {
+ my ($r, $w, $t);
+ defined($r = sysread($from_h, $buf, $size))
+ or goto fail_inner;
+ last unless $r;
+ for ($w = 0; $w < $r; $w += $t) {
+ $t = syswrite($to_h, $buf, $r - $w, $w)
+ or goto fail_inner;
+ }
+ }
+
+ close($to_h) || goto fail_open2 if $closeto;
+ close($from_h) || goto fail_open1 if $closefrom;
+
+ # Use this idiom to avoid uninitialized value warning.
+ return 1;
+
+ # All of these contortions try to preserve error messages...
+ fail_inner:
+ if ($closeto) {
+ $status = $!;
+ $! = 0;
+ close $to_h;
+ $! = $status unless $!;
+ }
+ fail_open2:
+ if ($closefrom) {
+ $status = $!;
+ $! = 0;
+ close $from_h;
+ $! = $status unless $!;
+ }
+ fail_open1:
+ return 0;
+}
+
+sub cp {
+ my($from,$to) = @_;
+ my(@fromstat) = stat $from;
+ my(@tostat) = stat $to;
+ my $perm;
+
+ return 0 unless copy(@_) and @fromstat;
+
+ if (@tostat) {
+ $perm = $tostat[2];
+ } else {
+ $perm = $fromstat[2] & ~(umask || 0);
+ @tostat = stat $to;
+ }
+ # Might be more robust to look for S_I* in Fcntl, but we're
+ # trying to avoid dependence on any XS-containing modules,
+ # since File::Copy is used during the Perl build.
+ $perm &= 07777;
+ if ($perm & 06000) {
+ croak("Unable to check setuid/setgid permissions for $to: $!")
+ unless @tostat;
+
+ if ($perm & 04000 and # setuid
+ $fromstat[4] != $tostat[4]) { # owner must match
+ $perm &= ~06000;
+ }
+
+ if ($perm & 02000 && $> != 0) { # if not root, setgid
+ my $ok = $fromstat[5] == $tostat[5]; # group must match
+ if ($ok) { # and we must be in group
+ $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
+ }
+ $perm &= ~06000 unless $ok;
+ }
+ }
+ return 0 unless @tostat;
+ return 1 if $perm == ($tostat[2] & 07777);
+ return eval { chmod $perm, $to; } ? 1 : 0;
+}
+
+sub _move {
+ croak("Usage: move(FROM, TO) ") unless @_ == 3;
+
+ my($from,$to,$fallback) = @_;
+
+ my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
+
+ if (-d $to && ! -d $from) {
+ $to = _catname($from, $to);
+ }
+
+ ($tosz1,$tomt1) = (stat($to))[7,9];
+ $fromsz = -s $from;
+ if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
+ # will not rename with overwrite
+ unlink $to;
+ }
+
+ my $rename_to = $to;
+ if (-$^O eq 'VMS' && -e $from) {
+
+ if (! -d $to && ! -d $from) {
+
+ my $vms_efs = _vms_efs();
+ my $unix_rpt = _vms_unix_rpt();
+ my $unix_mode = 0;
+ my $from_unix = 0;
+ $from_unix = 1 if ($from =~ /^\.\.?$/);
+ my $from_vms = 0;
+ $from_vms = 1 if ($from =~ m#[\[<\]]#);
+
+ # Need to know if we are in Unix mode.
+ if ($from_vms == $from_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $from_unix;
+ }
+
+ # VMS has sticky defaults on extensions, which means that
+ # if there is a null extension on the destination file, it
+ # will inherit the extension of the source file
+ # So add a '.' for a null extension.
+
+ # In unix_rpt mode, the trailing dot should not be added.
+
+ if ($vms_efs) {
+ $rename_to = $to;
+ } else {
+ $rename_to = VMS::Filespec::vmsify($to);
+ }
+ my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
+ $file = $file . '.'
+ unless (($file =~ /(?<!\^)\./) || $unix_rpt);
+ $rename_to = File::Spec->catpath($vol, $dirs, $file);
+
+ # Get rid of the old versions to be like UNIX
+ 1 while unlink $rename_to;
+ }
+ }
+
+ return 1 if rename $from, $rename_to;
+
+ # Did rename return an error even though it succeeded, because $to
+ # is on a remote NFS file system, and NFS lost the server's ack?
+ return 1 if defined($fromsz) && !-e $from && # $from disappeared
+ (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
+ ((!defined $tosz1) || # not before or
+ ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
+ $tosz2 == $fromsz; # it's all there
+
+ ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
+
+ {
+ local $@;
+ eval {
+ local $SIG{__DIE__};
+ $fallback->($from,$to) or die;
+ my($atime, $mtime) = (stat($from))[8,9];
+ utime($atime, $mtime, $to);
+ unlink($from) or die;
+ };
+ return 1 unless $@;
+ }
+ ($sts,$ossts) = ($! + 0, $^E + 0);
+
+ ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
+ unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
+ ($!,$^E) = ($sts,$ossts);
+ return 0;
+}
+
+sub move { _move(@_,\&copy); }
+sub mv { _move(@_,\&cp); }
+
+# &syscopy is an XSUB under OS/2
+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 {
+ return 0 unless @_ == 2;
+ return Win32::CopyFile(@_, 1);
+ };
+ } elsif ($macfiles) {
+ *syscopy = sub {
+ my($from, $to) = @_;
+ my($dir, $toname);
+
+ return 0 unless -e $from;
+
+ if ($to =~ /(.*:)([^:]+):?$/) {
+ ($dir, $toname) = ($1, $2);
+ } else {
+ ($dir, $toname) = (":", $to);
+ }
+
+ unlink($to);
+ Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
+ };
+ } else {
+ $Syscopy_is_copy = 1;
+ *syscopy = \&copy;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Copy - Copy files or filehandles
+
+=head1 SYNOPSIS
+
+ use File::Copy;
+
+ copy("file1","file2") or die "Copy failed: $!";
+ copy("Copy.pm",\*STDOUT);
+ move("/dev1/fileA","/dev2/fileB");
+
+ use File::Copy "cp";
+
+ $n = FileHandle->new("/a/file","r");
+ cp($n,"x");
+
+=head1 DESCRIPTION
+
+The File::Copy module provides two basic functions, C<copy> and
+C<move>, which are useful for getting the contents of a file from
+one place to another.
+
+=over 4
+
+=item copy
+X<copy> X<cp>
+
+The C<copy> function takes two
+parameters: a file to copy from and a file to copy to. Either
+argument may be a string, a FileHandle reference or a FileHandle
+glob. Obviously, if the first argument is a filehandle of some
+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.
+
+If the destination (second argument) already exists and is a directory,
+and the source (first argument) is not a filehandle, then the source
+file will be copied into the directory specified by the destination,
+using the same base name as the source file. It's a failure to have a
+filehandle as the source when the destination is a directory.
+
+B<Note that passing in
+files as handles instead of names may lead to loss of information
+on some operating systems; it is recommended that you use file
+names whenever possible.> Files are opened in binary mode where
+applicable. To get a consistent behaviour when copying from a
+filehandle to a file, use C<binmode> on the filehandle.
+
+An optional third parameter can be used to specify the buffer
+size used for copying. This is the number of bytes from the
+first file, that will be held in memory at any given time, before
+being written to the second file. The default buffer size depends
+upon the file, but will generally be the whole file (up to 2MB), or
+1k for filehandles that do not reference files (eg. sockets).
+
+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
+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
+ownership, inherited ACLs, etc.). If an error occurs in setting
+permissions, C<cp> will return 0, regardless of whether the file was
+successfully copied.
+
+=item move
+X<move> X<mv> X<rename>
+
+The C<move> function also takes two parameters: the current name
+and the intended name of the file to be moved. If the destination
+already exists and is a directory, and the source is not a
+directory, then the source file will be renamed into the directory
+specified by the destination.
+
+If possible, move() will simply rename the file. Otherwise, it copies
+the file to the new location and deletes the original. If an error occurs
+during this copy-and-delete process, you may be left with a (possibly partial)
+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>.
+
+=item syscopy
+X<syscopy>
+
+File::Copy also provides the C<syscopy> routine, which copies the
+file specified in the first parameter to the file specified in the
+second parameter, preserving OS-specific attributes and file
+structure. For Unix systems, this is equivalent to the simple
+C<copy> routine, which doesn't preserve OS-specific attributes. For
+VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
+systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
+this calls C<Win32::CopyFile>.
+
+On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
+if available.
+
+B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
+
+If both arguments to C<copy> are not file handles,
+then C<copy> will perform a "system copy" of
+the input file to a new output file, in order to preserve file
+attributes, indexed file structure, I<etc.> The buffer size
+parameter is ignored. If either argument to C<copy> is a
+handle to an opened file, then data is copied using Perl
+operators, and no effort is made to preserve file attributes
+or record structure.
+
+The system copy routine may also be called directly under VMS and OS/2
+as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
+is the routine that does the actual work for syscopy).
+
+=item rmscopy($from,$to[,$date_flag])
+X<rmscopy>
+
+The first and second arguments may be strings, typeglobs, typeglob
+references, or objects inheriting from IO::Handle;
+they are used in all cases to obtain the
+I<filespec> of the input and output files, respectively. The
+name and type of the input file are used as defaults for the
+output file, if necessary.
+
+A new version of the output file is always created, which
+inherits the structure and RMS attributes of the input file,
+except for owner and protections (and possibly timestamps;
+see below). All data from the input file is copied to the
+output file; if either of the first two parameters to C<rmscopy>
+is a file handle, its position is unchanged. (Note that this
+means a file handle pointing to the output file will be
+associated with an old version of that file after C<rmscopy>
+returns, not the newly created version.)
+
+The third parameter is an integer flag, which tells C<rmscopy>
+how to handle timestamps. If it is E<lt> 0, none of the input file's
+timestamps are propagated to the output file. If it is E<gt> 0, then
+it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
+timestamps other than the revision date are propagated; if bit 1
+is set, the revision date is propagated. If the third parameter
+to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
+if the name or type of the output file was explicitly specified,
+then no timestamps are propagated, but if they were taken implicitly
+from the input filespec, then all timestamps other than the
+revision date are propagated. If this parameter is not supplied,
+it defaults to 0.
+
+Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
+it sets C<$!>, deletes the output file, and returns 0.
+
+=back
+
+=head1 RETURN
+
+All functions return 1 on success, 0 on failure.
+$! will be set if an error was encountered.
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+On Mac OS (Classic), the path separator is ':', not '/', and the
+current directory is denoted as ':', not '.'. You should be careful
+about specifying relative pathnames. While a full path always begins
+with a volume name, a relative pathname should always begin with a
+':'. If specifying a volume name only, a trailing ':' is required.
+
+E.g.
+
+ copy("file1", "tmp"); # creates the file 'tmp' in the current directory
+ copy("file1", ":tmp:"); # creates :tmp:file1
+ copy("file1", ":tmp"); # same as above
+ copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do
+ # that, since it may cause confusion, see example #1)
+ copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume
+ copy("file1", ":tmp:file1"); # ok, partial path
+ copy("file1", "DataHD:"); # creates DataHD:file1
+
+ move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
+ # volume to another
+
+=back
+
+=head1 AUTHOR
+
+File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
+and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm
new file mode 100644
index 00000000000..496a14c1379
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm
@@ -0,0 +1,571 @@
+#!perl -w
+
+# use strict fails
+#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.
+
+#
+# Documentation at the __END__
+#
+
+package File::DosGlob;
+
+our $VERSION = '1.01';
+use strict;
+use warnings;
+
+sub doglob {
+ my $cond = shift;
+ my @retval = ();
+ #print "doglob: ", join('|', @_), "\n";
+ OUTER:
+ for my $pat (@_) {
+ my @matched = ();
+ my @globdirs = ();
+ my $head = '.';
+ my $sepchr = '/';
+ my $tail;
+ next OUTER unless defined $pat and $pat ne '';
+ # if arg is within quotes strip em and do no globbing
+ if ($pat =~ /^"(.*)"\z/s) {
+ $pat = $1;
+ if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
+ else { push(@retval, $pat) if -e $pat }
+ next OUTER;
+ }
+ # wildcards with a drive prefix such as h:*.pm must be changed
+ # to h:./*.pm to expand correctly
+ if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
+ substr($pat,0,2) = $1 . "./";
+ }
+ if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
+ ($head, $sepchr, $tail) = ($1,$2,$3);
+ #print "div: |$head|$sepchr|$tail|\n";
+ push (@retval, $pat), next OUTER if $tail eq '';
+ if ($head =~ /[*?]/) {
+ @globdirs = doglob('d', $head);
+ push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
+ next OUTER if @globdirs;
+ }
+ $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
+ $pat = $tail;
+ }
+ #
+ # If file component has no wildcards, we can avoid opendir
+ unless ($pat =~ /[*?]/) {
+ $head = '' if $head eq '.';
+ $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+ $head .= $pat;
+ if ($cond eq 'd') { push(@retval,$head) if -d $head }
+ else { push(@retval,$head) if -e $head }
+ next OUTER;
+ }
+ opendir(D, $head) or next OUTER;
+ my @leaves = readdir D;
+ closedir D;
+ $head = '' if $head eq '.';
+ $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+
+ # escape regex metachars but not glob chars
+ $pat =~ s:([].+^\-\${}[|]):\\$1:g;
+ # and convert DOS-style wildcards to regex
+ $pat =~ s/\*/.*/g;
+ $pat =~ s/\?/.?/g;
+
+ #print "regex: '$pat', head: '$head'\n";
+ my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
+ INNER:
+ for my $e (@leaves) {
+ next INNER if $e eq '.' or $e eq '..';
+ next INNER if $cond eq 'd' and ! -d "$head$e";
+ push(@matched, "$head$e"), next INNER if &$matchsub($e);
+ #
+ # [DOS compatibility special case]
+ # Failed, add a trailing dot and try again, but only
+ # if name does not have a dot in it *and* pattern
+ # has a dot *and* name is shorter than 9 chars.
+ #
+ if (index($e,'.') == -1 and length($e) < 9
+ and index($pat,'\\.') != -1) {
+ push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
+ }
+ }
+ push @retval, @matched if @matched;
+ }
+ return @retval;
+}
+
+
+#
+# Do DOS-like globbing on Mac OS
+#
+sub doglob_Mac {
+ my $cond = shift;
+ my @retval = ();
+
+ #print "doglob_Mac: ", join('|', @_), "\n";
+ OUTER:
+ for my $arg (@_) {
+ local $_ = $arg;
+ my @matched = ();
+ my @globdirs = ();
+ my $head = ':';
+ my $not_esc_head = $head;
+ my $sepchr = ':';
+ next OUTER unless defined $_ and $_ ne '';
+ # if arg is within quotes strip em and do no globbing
+ if (/^"(.*)"\z/s) {
+ $_ = $1;
+ # $_ may contain escaped metachars '\*', '\?' and '\'
+ my $not_esc_arg = $_;
+ $not_esc_arg =~ s/\\([*?\\])/$1/g;
+ if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
+ else { push(@retval, $not_esc_arg) if -e $not_esc_arg }
+ next OUTER;
+ }
+
+ if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
+ my $tail;
+ ($head, $sepchr, $tail) = ($1,$2,$3);
+ #print "div: |$head|$sepchr|$tail|\n";
+ push (@retval, $_), next OUTER if $tail eq '';
+ #
+ # $head may contain escaped metachars '\*' and '\?'
+
+ my $tmp_head = $head;
+ # if a '*' or '?' is preceded by an odd count of '\', temporary delete
+ # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
+ # wildcards
+ $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
+
+ if ($tmp_head =~ /[*?]/) { # if there are wildcards ...
+ @globdirs = doglob_Mac('d', $head);
+ push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
+ next OUTER if @globdirs;
+ }
+
+ $head .= $sepchr;
+ $not_esc_head = $head;
+ # unescape $head for file operations
+ $not_esc_head =~ s/\\([*?\\])/$1/g;
+ $_ = $tail;
+ }
+ #
+ # If file component has no wildcards, we can avoid opendir
+
+ my $tmp_tail = $_;
+ # if a '*' or '?' is preceded by an odd count of '\', temporary delete
+ # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
+ # wildcards
+ $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
+
+ unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
+ $not_esc_head = $head = '' if $head eq ':';
+ my $not_esc_tail = $_;
+ # unescape $head and $tail for file operations
+ $not_esc_tail =~ s/\\([*?\\])/$1/g;
+ $head .= $_;
+ $not_esc_head .= $not_esc_tail;
+ if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
+ else { push(@retval,$head) if -e $not_esc_head }
+ next OUTER;
+ }
+ #print "opendir($not_esc_head)\n";
+ opendir(D, $not_esc_head) or next OUTER;
+ my @leaves = readdir D;
+ closedir D;
+
+ # escape regex metachars but not '\' and glob chars '*', '?'
+ $_ =~ s:([].+^\-\${}[|]):\\$1:g;
+ # and convert DOS-style wildcards to regex,
+ # but only if they are not escaped
+ $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
+
+ #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n";
+ my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
+ warn($@), next OUTER if $@;
+ INNER:
+ for my $e (@leaves) {
+ next INNER if $e eq '.' or $e eq '..';
+ next INNER if $cond eq 'd' and ! -d "$not_esc_head$e";
+
+ if (&$matchsub($e)) {
+ my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ?
+ "$e" : "$not_esc_head$e";
+ #
+ # On Mac OS, the two glob metachars '*' and '?' and the escape
+ # char '\' are valid characters for file and directory names.
+ # We have to escape and treat them specially.
+ $leave =~ s|([*?\\])|\\$1|g;
+ push(@matched, $leave);
+ next INNER;
+ }
+ }
+ push @retval, @matched if @matched;
+ }
+ return @retval;
+}
+
+#
+# _expand_volume() will only be used on Mac OS (Classic):
+# Takes an array of original patterns as argument and returns an array of
+# possibly modified patterns. Each original pattern is processed like
+# that:
+# + If there's a volume name in the pattern, we push a separate pattern
+# for each mounted volume that matches (with '*', '?' and '\' escaped).
+# + If there's no volume name in the original pattern, it is pushed
+# unchanged.
+# Note that the returned array of patterns may be empty.
+#
+sub _expand_volume {
+
+ require MacPerl; # to be verbose
+
+ my @pat = @_;
+ my @new_pat = ();
+ my @FSSpec_Vols = MacPerl::Volumes();
+ my @mounted_volumes = ();
+
+ foreach my $spec_vol (@FSSpec_Vols) {
+ # push all mounted volumes into array
+ push @mounted_volumes, MacPerl::MakePath($spec_vol);
+ }
+ #print "mounted volumes: |@mounted_volumes|\n";
+
+ while (@pat) {
+ my $pat = shift @pat;
+ if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
+ my $vol_pat = $1;
+ my $tail = $2;
+ #
+ # escape regex metachars but not '\' and glob chars '*', '?'
+ $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
+ # and convert DOS-style wildcards to regex,
+ # but only if they are not escaped
+ $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
+ #print "volume regex: '$vol_pat' \n";
+
+ foreach my $volume (@mounted_volumes) {
+ if ($volume =~ m|^$vol_pat\z|ios) {
+ #
+ # On Mac OS, the two glob metachars '*' and '?' and the
+ # escape char '\' are valid characters for volume names.
+ # We have to escape and treat them specially.
+ $volume =~ s|([*?\\])|\\$1|g;
+ push @new_pat, $volume . $tail;
+ }
+ }
+ } else { # no volume name in pattern, push original pattern
+ push @new_pat, $pat;
+ }
+ }
+ return @new_pat;
+}
+
+
+#
+# _preprocess_pattern() will only be used on Mac OS (Classic):
+# Resolves any updirs in the pattern. Removes a single trailing colon
+# from the pattern, unless it's a volume name pattern like "*HD:"
+#
+sub _preprocess_pattern {
+ my @pat = @_;
+
+ foreach my $p (@pat) {
+ my $proceed;
+ # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
+ do {
+ $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
+ } while ($proceed);
+ # remove a single trailing colon, e.g. ":*:" -> ":*"
+ $p =~ s/:([^:]+):\z/:$1/;
+ }
+ return @pat;
+}
+
+
+#
+# _un_escape() will only be used on Mac OS (Classic):
+# Unescapes a list of arguments which may contain escaped
+# metachars '*', '?' and '\'.
+#
+sub _un_escape {
+ foreach (@_) {
+ s/\\([*?\\])/$1/g;
+ }
+ return @_;
+}
+
+#
+# this can be used to override CORE::glob in a specific
+# package by saying C<use File::DosGlob 'glob';> in that
+# namespace.
+#
+
+# context (keyed by second cxix arg provided by core)
+my %iter;
+my %entries;
+
+sub glob {
+ my($pat,$cxix) = @_;
+ my @pat;
+
+ # glob without args defaults to $_
+ $pat = $_ unless defined $pat;
+
+ # extract patterns
+ if ($pat =~ /\s/) {
+ require Text::ParseWords;
+ @pat = Text::ParseWords::parse_line('\s+',0,$pat);
+ }
+ else {
+ push @pat, $pat;
+ }
+
+ # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
+ # abc3 will be the original {3} (and drop the {}).
+ # abc1 abc2 will be put in @appendpat.
+ # This was just the esiest way, not nearly the best.
+ REHASH: {
+ my @appendpat = ();
+ for (@pat) {
+ # There must be a "," I.E. abc{efg} is not what we want.
+ while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
+ my ($start, $match, $end) = ($1, $2, $3);
+ #print "Got: \n\t$start\n\t$match\n\t$end\n";
+ my $tmp = "$start$match$end";
+ while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
+ #print "Striped: $tmp\n";
+ # these expanshions will be preformed by the original,
+ # when we call REHASH.
+ }
+ push @appendpat, ("$tmp");
+ s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
+ if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
+ $match = $1;
+ #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
+ $_ = "$start$match$end";
+ }
+ }
+ #print "Sould have "GOT" vs "Got"!\n";
+ #FIXME: There should be checking for this.
+ # How or what should be done about failure is beond me.
+ }
+ if ( $#appendpat != -1
+ ) {
+ #print "LOOP\n";
+ #FIXME: Max loop, no way! :")
+ for ( @appendpat ) {
+ push @pat, $_;
+ }
+ goto REHASH;
+ }
+ }
+ for ( @pat ) {
+ s/\\{/{/g;
+ s/\\}/}/g;
+ s/\\,/,/g;
+ }
+ #print join ("\n", @pat). "\n";
+
+ # assume global context if not provided one
+ $cxix = '_G_' unless defined $cxix;
+ $iter{$cxix} = 0 unless exists $iter{$cxix};
+
+ # if we're just beginning, do it all first
+ if ($iter{$cxix} == 0) {
+ if ($^O eq 'MacOS') {
+ # first, take care of updirs and trailing colons
+ @pat = _preprocess_pattern(@pat);
+ # expand volume names
+ @pat = _expand_volume(@pat);
+ $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()];
+ } else {
+ $entries{$cxix} = [doglob(1,@pat)];
+ }
+ }
+
+ # chuck it all out, quick or slow
+ if (wantarray) {
+ delete $iter{$cxix};
+ return @{delete $entries{$cxix}};
+ }
+ else {
+ if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
+ return shift @{$entries{$cxix}};
+ }
+ else {
+ # return undef for EOL
+ delete $iter{$cxix};
+ delete $entries{$cxix};
+ return undef;
+ }
+ }
+}
+
+{
+ no strict 'refs';
+
+ sub import {
+ my $pkg = shift;
+ return unless @_;
+ my $sym = shift;
+ my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
+ *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
+ }
+}
+1;
+
+__END__
+
+=head1 NAME
+
+File::DosGlob - DOS like globbing and then some
+
+=head1 SYNOPSIS
+
+ require 5.004;
+
+ # override CORE::glob in current package
+ use File::DosGlob 'glob';
+
+ # override CORE::glob in ALL packages (use with extreme caution!)
+ use File::DosGlob 'GLOBAL_glob';
+
+ @perlfiles = glob "..\\pe?l/*.p?";
+ print <..\\pe?l/*.p?>;
+
+ # from the command line (overrides only in main::)
+ > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
+
+=head1 DESCRIPTION
+
+A module that implements DOS-like globbing with a few enhancements.
+It is largely compatible with perlglob.exe (the M$ setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
+that it will find something like '..\lib\File/DosGlob.pm' alright).
+Note that all path components are case-insensitive, and that
+backslashes and forward slashes are both accepted, and preserved.
+You may have to double the backslashes if you are putting them in
+literally, due to double-quotish parsing of the pattern by perl.
+
+Spaces in the argument delimit distinct patterns, so
+C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
+or C<.dll>. If you want to put in literal spaces in the glob
+pattern, you can escape them with either double quotes, or backslashes.
+e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
+C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
+C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
+of the quoting rules used.
+
+Extending it to csh patterns is left as an exercise to the reader.
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Mac OS (Classic) users should note a few differences. The specification
+of pathnames in glob patterns adheres to the usual Mac OS conventions:
+The path separator is a colon ':', not a slash '/' or backslash '\'. A
+full path always begins with a volume name. A relative pathname on Mac
+OS must always begin with a ':', except when specifying a file or
+directory name in the current working directory, where the leading colon
+is optional. If specifying a volume name only, a trailing ':' is
+required. Due to these rules, a glob like E<lt>*:E<gt> will find all
+mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
+all files and directories in the current directory.
+
+Note that updirs in the glob pattern are resolved before the matching begins,
+i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
+that a single trailing ':' in the pattern is ignored (unless it's a volume
+name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories
+I<and> files (and not, as one might expect, only directories).
+
+The metachars '*', '?' and the escape char '\' are valid characters in
+volume, directory and file names on Mac OS. Hence, if you want to match
+a '*', '?' or '\' literally, you have to escape these characters. Due to
+perl's quoting rules, things may get a bit complicated, when you want to
+match a string like '\*' literally, or when you want to match '\' literally,
+but treat the immediately following character '*' as metachar. So, here's a
+rule of thumb (applies to both single- and double-quoted strings): escape
+each '*' or '?' or '\' with a backslash, if you want to treat them literally,
+and then double each backslash and your are done. E.g.
+
+- Match '\*' literally
+
+ escape both '\' and '*' : '\\\*'
+ double the backslashes : '\\\\\\*'
+
+(Internally, the glob routine sees a '\\\*', which means that both '\' and
+'*' are escaped.)
+
+
+- Match '\' literally, treat '*' as metachar
+
+ escape '\' but not '*' : '\\*'
+ double the backslashes : '\\\\*'
+
+(Internally, the glob routine sees a '\\*', which means that '\' is escaped and
+'*' is not.)
+
+Note that you also have to quote literal spaces in the glob pattern, as described
+above.
+
+=back
+
+=head1 EXPORTS (by request only)
+
+glob()
+
+=head1 BUGS
+
+Should probably be built into the core, and needs to stop
+pandering to DOS habits. Needs a dose of optimizium too.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@activestate.com>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+Support for globally overriding glob() (GSAR 3-JUN-98)
+
+=item *
+
+Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
+
+=item *
+
+A few dir-vs-file optimizations result in glob importation being
+10 times faster than using perlglob.exe, and using perlglob.bat is
+only twice as slow as perlglob.exe (GSAR 28-MAY-97)
+
+=item *
+
+Several cleanups prompted by lack of compatible perlglob.exe
+under Borland (GSAR 27-MAY-97)
+
+=item *
+
+Initial version (GSAR 20-FEB-97)
+
+=back
+
+=head1 SEE ALSO
+
+perl
+
+perlglob.bat
+
+Text::ParseWords
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm
new file mode 100644
index 00000000000..4aabc29be55
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm
@@ -0,0 +1,1466 @@
+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.24';
+$VERSION = eval $VERSION; # avoid warnings with development releases
+$PREFER_BIN = 0; # XXX TODO implement
+$FROM_EMAIL = 'File-Fetch@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 iosock| ],
+ 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 $class->_error(loc(
+ "Hostname required when fetching from '%1'",$args->scheme));
+ }
+
+ for (qw[path file]) {
+ unless( $args->$_() ) { # 5.5.x needs the ()
+ return $class->_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 = $class->_parse_uri( $uri ) or return;
+
+ ### make it into a FFI object ###
+ my $ff = $class->_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;
+ }
+}
+
+### Simple IO::Socket::INET fetching ###
+sub _iosock_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ my $use_list = {
+ 'IO::Socket::INET' => '0.0',
+ 'IO::Select' => '0.0',
+ };
+
+ if( can_load(modules => $use_list) ) {
+ my $sock = IO::Socket::INET->new(
+ PeerHost => $self->host,
+ ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
+ );
+
+ unless ( $sock ) {
+ return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
+ }
+
+ my $fh = FileHandle->new;
+
+ # Check open()
+
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
+
+ my $path = File::Spec::Unix->catfile( $self->path, $self->file );
+ my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
+ $sock->send( $req );
+
+ my $select = IO::Select->new( $sock );
+
+ my $resp = '';
+ my $normal = 0;
+ while ( $select->can_read( $TIMEOUT || 60 ) ) {
+ my $ret = $sock->sysread( $resp, 4096, length($resp) );
+ if ( !defined $ret or $ret == 0 ) {
+ $select->remove( $sock );
+ $normal++;
+ }
+ }
+ close $sock;
+
+ unless ( $normal ) {
+ return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
+ }
+
+ # Check the "response"
+ # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1)
+ $resp =~ s/^(\x0d?\x0a)+//;
+ # Check it is an HTTP response
+ unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
+ return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
+ }
+
+ # Check for OK
+ my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
+ unless ( $code eq '200' ) {
+ return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
+ }
+
+ print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ close $fh;
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'iosock'} = 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, iosock
+ 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.
+
+C<iosock> is a very limited L<IO::Socket::INET> based mechanism for
+retrieving C<http> schemed urls. It doesn't follow redirects for instance.
+
+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@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
+ IO::Socket => iosock
+
+=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@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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:
+
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm
new file mode 100644
index 00000000000..e72f3e32b30
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Find.pm
@@ -0,0 +1,1349 @@
+package File::Find;
+use 5.006;
+use strict;
+use warnings;
+use warnings::register;
+our $VERSION = '1.15';
+require Exporter;
+require Cwd;
+
+#
+# Modified to ensure sub-directory traversal order is not inverded by stack
+# push and pops. That is remains in the same order as in the directory file,
+# or user pre-processing (EG:sorted).
+#
+
+=head1 NAME
+
+File::Find - Traverse a directory tree.
+
+=head1 SYNOPSIS
+
+ use File::Find;
+ find(\&wanted, @directories_to_search);
+ sub wanted { ... }
+
+ use File::Find;
+ finddepth(\&wanted, @directories_to_search);
+ sub wanted { ... }
+
+ use File::Find;
+ find({ wanted => \&process, follow => 1 }, '.');
+
+=head1 DESCRIPTION
+
+These are functions for searching through directory trees doing work
+on each file found similar to the Unix I<find> command. File::Find
+exports two functions, C<find> and C<finddepth>. They work similarly
+but have subtle differences.
+
+=over 4
+
+=item B<find>
+
+ find(\&wanted, @directories);
+ find(\%options, @directories);
+
+C<find()> does a depth-first search over the given C<@directories> in
+the order they are given. For each file or directory found, it calls
+the C<&wanted> subroutine. (See below for details on how to use the
+C<&wanted> function). Additionally, for each directory found, it will
+C<chdir()> into that directory and continue the search, invoking the
+C<&wanted> function on each file or subdirectory in the directory.
+
+=item B<finddepth>
+
+ finddepth(\&wanted, @directories);
+ finddepth(\%options, @directories);
+
+C<finddepth()> works just like C<find()> except that it invokes the
+C<&wanted> function for a directory I<after> invoking it for the
+directory's contents. It does a postorder traversal instead of a
+preorder traversal, working from the bottom of the directory tree up
+where C<find()> works from the top of the tree down.
+
+=back
+
+=head2 %options
+
+The first argument to C<find()> is either a code reference to your
+C<&wanted> function, or a hash reference describing the operations
+to be performed for each file. The
+code reference is described in L<The wanted function> below.
+
+Here are the possible keys for the hash:
+
+=over 3
+
+=item C<wanted>
+
+The value should be a code reference. This code reference is
+described in L<The wanted function> below. The C<&wanted> subroutine is
+mandatory.
+
+=item C<bydepth>
+
+Reports the name of a directory only AFTER all its entries
+have been reported. Entry point C<finddepth()> is a shortcut for
+specifying C<< { bydepth => 1 } >> in the first argument of C<find()>.
+
+=item C<preprocess>
+
+The value should be a code reference. This code reference is used to
+preprocess the current directory. The name of the currently processed
+directory is in C<$File::Find::dir>. Your preprocessing function is
+called after C<readdir()>, but before the loop that calls the C<wanted()>
+function. It is called with a list of strings (actually file/directory
+names) and is expected to return a list of strings. The code can be
+used to sort the file/directory names alphabetically, numerically,
+or to filter out directory entries based on their name alone. When
+I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
+
+=item C<postprocess>
+
+The value should be a code reference. It is invoked just before leaving
+the currently processed directory. It is called in void context with no
+arguments. The name of the current directory is in C<$File::Find::dir>. This
+hook is handy for summarizing a directory, such as calculating its disk
+usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
+no-op.
+
+=item C<follow>
+
+Causes symbolic links to be followed. Since directory trees with symbolic
+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.
+If either I<follow> or I<follow_fast> is in effect:
+
+=over 6
+
+=item *
+
+It is guaranteed that an I<lstat> has been called before the user's
+C<wanted()> function is called. This enables fast file checks involving S<_>.
+Note that this guarantee no longer holds if I<follow> or I<follow_fast>
+are not set.
+
+=item *
+
+There is a variable C<$File::Find::fullname> which holds the absolute
+pathname of the file with all symbolic links resolved. If the link is
+a dangling symbolic link, then fullname will be set to C<undef>.
+
+=back
+
+This is a no-op on Win32.
+
+=item C<follow_fast>
+
+This is similar to I<follow> except that it may report some files more
+than once. It does detect cycles, however. Since only symbolic links
+have to be hashed, this is much cheaper both in space and time. If
+processing a file more than once (by the user's C<wanted()> function)
+is worse than just taking time, the option I<follow> should be used.
+
+This is also a no-op on Win32.
+
+=item C<follow_skip>
+
+C<follow_skip==1>, which is the default, causes all files which are
+neither directories nor symbolic links to be ignored if they are about
+to be processed a second time. If a directory or a symbolic link
+are about to be processed a second time, File::Find dies.
+
+C<follow_skip==0> causes File::Find to die if any file is about to be
+processed a second time.
+
+C<follow_skip==2> causes File::Find to ignore any duplicate files and
+directories but to proceed normally otherwise.
+
+=item C<dangling_symlinks>
+
+If true and a code reference, will be called with the symbolic link
+name and the directory it lives in as arguments. Otherwise, if true
+and warnings are on, warning "symbolic_link_name is a dangling
+symbolic link\n" will be issued. If false, the dangling symbolic link
+will be silently ignored.
+
+=item C<no_chdir>
+
+Does not C<chdir()> to each directory as it recurses. The C<wanted()>
+function will need to be aware of this, of course. In this case,
+C<$_> will be the same as C<$File::Find::name>.
+
+=item C<untaint>
+
+If find is used in taint-mode (-T command line switch or if EUID != UID
+or if EGID != GID) then internally directory names have to be untainted
+before they can be chdir'ed to. Therefore they are checked against a regular
+expression I<untaint_pattern>. Note that all names passed to the user's
+I<wanted()> function are still tainted. If this option is used while
+not in taint-mode, C<untaint> is a no-op.
+
+=item C<untaint_pattern>
+
+See above. This should be set using the C<qr> quoting operator.
+The default is set to C<qr|^([-+@\w./]+)$|>.
+Note that the parentheses are vital.
+
+=item C<untaint_skip>
+
+If set, a directory which fails the I<untaint_pattern> is skipped,
+including all its sub-directories. The default is to 'die' in such a case.
+
+=back
+
+=head2 The wanted function
+
+The C<wanted()> function does whatever verifications you want on
+each file and directory. Note that despite its name, the C<wanted()>
+function is a generic callback function, and does B<not> tell
+File::Find if a file is "wanted" or not. In fact, its return value
+is ignored.
+
+The wanted function takes no arguments but rather does its work
+through a collection of variables.
+
+=over 4
+
+=item C<$File::Find::dir> is the current directory name,
+
+=item C<$_> is the current filename within that directory
+
+=item C<$File::Find::name> is the complete pathname to the file.
+
+=back
+
+The above variables have all been localized and may be changed without
+affecting data outside of the wanted function.
+
+For example, when examining the file F</some/path/foo.ext> you will have:
+
+ $File::Find::dir = /some/path/
+ $_ = foo.ext
+ $File::Find::name = /some/path/foo.ext
+
+You are chdir()'d to C<$File::Find::dir> when the function is called,
+unless C<no_chdir> was specified. Note that when changing to
+directories is in effect the root directory (F</>) is a somewhat
+special case inasmuch as the concatenation of C<$File::Find::dir>,
+C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The
+table below summarizes all variants:
+
+ $File::Find::name $File::Find::dir $_
+ default / / .
+ no_chdir=>0 /etc / etc
+ /etc/x /etc x
+
+ no_chdir=>1 / / /
+ /etc / /etc
+ /etc/x /etc /etc/x
+
+
+When C<follow> or C<follow_fast> are in effect, there is
+also a C<$File::Find::fullname>. The function may set
+C<$File::Find::prune> to prune the tree unless C<bydepth> was
+specified. Unless C<follow> or C<follow_fast> is specified, for
+compatibility reasons (find.pl, find2perl) there are in addition the
+following globals available: C<$File::Find::topdir>,
+C<$File::Find::topdev>, C<$File::Find::topino>,
+C<$File::Find::topmode> and C<$File::Find::topnlink>.
+
+This library is useful for the C<find2perl> tool, which when fed,
+
+ find2perl / -name .nfs\* -mtime +7 \
+ -exec rm -f {} \; -o -fstype nfs -prune
+
+produces something like:
+
+ sub wanted {
+ /^\.nfs.*\z/s &&
+ (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
+ int(-M _) > 7 &&
+ unlink($_)
+ ||
+ ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
+ $dev < 0 &&
+ ($File::Find::prune = 1);
+ }
+
+Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical
+filehandle that caches the information from the preceding
+C<stat()>, C<lstat()>, or filetest.
+
+Here's another interesting wanted function. It will find all symbolic
+links that don't resolve:
+
+ sub wanted {
+ -l && !-e && print "bogus link: $File::Find::name\n";
+ }
+
+See also the script C<pfind> on CPAN for a nice application of this
+module.
+
+=head1 WARNINGS
+
+If you run your program with the C<-w> switch, or if you use the
+C<warnings> pragma, File::Find will report warnings for several weird
+situations. You can disable these warnings by putting the statement
+
+ no warnings 'File::Find';
+
+in the appropriate scope. See L<perllexwarn> for more info about lexical
+warnings.
+
+=head1 CAVEAT
+
+=over 2
+
+=item $dont_use_nlink
+
+You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to
+force File::Find to always stat directories. This was used for file systems
+that do not have an C<nlink> count matching the number of sub-directories.
+Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file
+system) and a couple of others.
+
+You shouldn't need to set this variable, since File::Find should now detect
+such file systems on-the-fly and switch itself to using stat. This works even
+for parts of your file system, like a mounted CD-ROM.
+
+If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs.
+
+=item symlinks
+
+Be aware that the option to follow symbolic links can be dangerous.
+Depending on the structure of the directory tree (including symbolic
+links to directories) you might traverse a given (physical) directory
+more than once (only if C<follow_fast> is in effect).
+Furthermore, deleting or changing files in a symbolically linked directory
+might cause very unpleasant surprises, since you delete or change files
+in an unknown directory.
+
+=back
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Mac OS (Classic) users should note a few differences:
+
+=over 4
+
+=item *
+
+The path separator is ':', not '/', and the current directory is denoted
+as ':', not '.'. You should be careful about specifying relative pathnames.
+While a full path always begins with a volume name, a relative pathname
+should always begin with a ':'. If specifying a volume name only, a
+trailing ':' is required.
+
+=item *
+
+C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
+contains the name of a directory, that name may or may not end with a
+':'. Likewise, C<$File::Find::name>, which contains the complete
+pathname to that directory, and C<$File::Find::fullname>, which holds
+the absolute pathname of that directory with all symbolic links resolved,
+may or may not end with a ':'.
+
+=item *
+
+The default C<untaint_pattern> (see above) on Mac OS is set to
+C<qr|^(.+)$|>. Note that the parentheses are vital.
+
+=item *
+
+The invisible system file "Icon\015" is ignored. While this file may
+appear in every directory, there are some more invisible system files
+on every volume, which are all located at the volume root level (i.e.
+"MacintoshHD:"). These system files are B<not> excluded automatically.
+Your filter may use the following code to recognize invisible files or
+directories (requires Mac::Files):
+
+ use Mac::Files;
+
+ # invisible() -- returns 1 if file/directory is invisible,
+ # 0 if it's visible or undef if an error occurred
+
+ sub invisible($) {
+ my $file = shift;
+ my ($fileCat, $fileInfo);
+ my $invisible_flag = 1 << 14;
+
+ if ( $fileCat = FSpGetCatInfo($file) ) {
+ if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
+ return (($fileInfo->fdFlags & $invisible_flag) && 1);
+ }
+ }
+ return undef;
+ }
+
+Generally, invisible files are system files, unless an odd application
+decides to use invisible files for its own purposes. To distinguish
+such files from system files, you have to look at the B<type> and B<creator>
+file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
+C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
+(see MacPerl.pm for details).
+
+Files that appear on the desktop actually reside in an (hidden) directory
+named "Desktop Folder" on the particular disk volume. Note that, although
+all desktop files appear to be on the same "virtual" desktop, each disk
+volume actually maintains its own "Desktop Folder" directory.
+
+=back
+
+=back
+
+=head1 BUGS AND CAVEATS
+
+Despite the name of the C<finddepth()> function, both C<find()> and
+C<finddepth()> perform a depth-first search of the directory
+hierarchy.
+
+=head1 HISTORY
+
+File::Find used to produce incorrect results if called recursively.
+During the development of perl 5.8 this bug was fixed.
+The first fixed version of File::Find was 1.01.
+
+=head1 SEE ALSO
+
+find, find2perl.
+
+=cut
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(find finddepth);
+
+
+use strict;
+my $Is_VMS;
+my $Is_MacOS;
+
+require File::Basename;
+require File::Spec;
+
+# Should ideally be my() not our() but local() currently
+# refuses to operate on lexicals
+
+our %SLnkSeen;
+our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process, $dangling_symlinks);
+
+sub contract_name {
+ my ($cdir,$fn) = @_;
+
+ return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;
+
+ $cdir = substr($cdir,0,rindex($cdir,'/')+1);
+
+ $fn =~ s|^\./||;
+
+ my $abs_name= $cdir . $fn;
+
+ if (substr($fn,0,3) eq '../') {
+ 1 while $abs_name =~ s!/[^/]*/\.\./+!/!;
+ }
+
+ return $abs_name;
+}
+
+# return the absolute name of a directory or file
+sub contract_name_Mac {
+ my ($cdir,$fn) = @_;
+ my $abs_name;
+
+ if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
+
+ my $colon_count = length ($1);
+ if ($colon_count == 1) {
+ $abs_name = $cdir . $2;
+ return $abs_name;
+ }
+ else {
+ # need to move up the tree, but
+ # only if it's not a volume name
+ for (my $i=1; $i<$colon_count; $i++) {
+ unless ($cdir =~ /^[^:]+:$/) { # volume name
+ $cdir =~ s/[^:]+:$//;
+ }
+ else {
+ return undef;
+ }
+ }
+ $abs_name = $cdir . $2;
+ return $abs_name;
+ }
+
+ }
+ else {
+
+ # $fn may be a valid path to a directory or file or (dangling)
+ # symlink, without a leading ':'
+ if ( (-e $fn) || (-l $fn) ) {
+ if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
+ return $fn; # $fn is already an absolute path
+ }
+ else {
+ $abs_name = $cdir . $fn;
+ return $abs_name;
+ }
+ }
+ else { # argh!, $fn is not a valid directory/file
+ return undef;
+ }
+ }
+}
+
+sub PathCombine($$) {
+ my ($Base,$Name) = @_;
+ my $AbsName;
+
+ if ($Is_MacOS) {
+ # $Name is the resolved symlink (always a full path on MacOS),
+ # i.e. there's no need to call contract_name_Mac()
+ $AbsName = $Name;
+
+ # (simple) check for recursion
+ if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
+ return undef;
+ }
+ }
+ else {
+ if (substr($Name,0,1) eq '/') {
+ $AbsName= $Name;
+ }
+ else {
+ $AbsName= contract_name($Base,$Name);
+ }
+
+ # (simple) check for recursion
+ my $newlen= length($AbsName);
+ if ($newlen <= length($Base)) {
+ if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
+ && $AbsName eq substr($Base,0,$newlen))
+ {
+ return undef;
+ }
+ }
+ }
+ return $AbsName;
+}
+
+sub Follow_SymLink($) {
+ my ($AbsName) = @_;
+
+ my ($NewName,$DEV, $INO);
+ ($DEV, $INO)= lstat $AbsName;
+
+ while (-l _) {
+ if ($SLnkSeen{$DEV, $INO}++) {
+ if ($follow_skip < 2) {
+ die "$AbsName is encountered a second time";
+ }
+ else {
+ return undef;
+ }
+ }
+ $NewName= PathCombine($AbsName, readlink($AbsName));
+ unless(defined $NewName) {
+ if ($follow_skip < 2) {
+ die "$AbsName is a recursive symbolic link";
+ }
+ else {
+ return undef;
+ }
+ }
+ else {
+ $AbsName= $NewName;
+ }
+ ($DEV, $INO) = lstat($AbsName);
+ return undef unless defined $DEV; # dangling symbolic link
+ }
+
+ if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
+ if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
+ die "$AbsName encountered a second time";
+ }
+ else {
+ return undef;
+ }
+ }
+
+ return $AbsName;
+}
+
+our($dir, $name, $fullname, $prune);
+sub _find_dir_symlnk($$$);
+sub _find_dir($$$);
+
+# check whether or not a scalar variable is tainted
+# (code straight from the Camel, 3rd ed., page 561)
+sub is_tainted_pp {
+ my $arg = shift;
+ my $nada = substr($arg, 0, 0); # zero-length
+ local $@;
+ eval { eval "# $nada" };
+ return length($@) != 0;
+}
+
+sub _find_opt {
+ my $wanted = shift;
+ die "invalid top directory" unless defined $_[0];
+
+ # This function must local()ize everything because callbacks may
+ # call find() or finddepth()
+
+ local %SLnkSeen;
+ local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process, $dangling_symlinks);
+ local($dir, $name, $fullname, $prune);
+ local *_ = \my $a;
+
+ my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
+ if ($Is_VMS) {
+ # VMS returns this by default in VMS format which just doesn't
+ # work for the rest of this module.
+ $cwd = VMS::Filespec::unixpath($cwd);
+
+ # Apparently this is not expected to have a trailing space.
+ # To attempt to make VMS/UNIX conversions mostly reversable,
+ # a trailing slash is needed. The run-time functions ignore the
+ # resulting double slash, but it causes the perl tests to fail.
+ $cwd =~ s#/\z##;
+
+ # This comes up in upper case now, but should be lower.
+ # In the future this could be exact case, no need to change.
+ }
+ my $cwd_untainted = $cwd;
+ my $check_t_cwd = 1;
+ $wanted_callback = $wanted->{wanted};
+ $bydepth = $wanted->{bydepth};
+ $pre_process = $wanted->{preprocess};
+ $post_process = $wanted->{postprocess};
+ $no_chdir = $wanted->{no_chdir};
+ $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow};
+ $follow = $^O eq 'MSWin32' ? 0 :
+ $full_check || $wanted->{follow_fast};
+ $follow_skip = $wanted->{follow_skip};
+ $untaint = $wanted->{untaint};
+ $untaint_pat = $wanted->{untaint_pattern};
+ $untaint_skip = $wanted->{untaint_skip};
+ $dangling_symlinks = $wanted->{dangling_symlinks};
+
+ # for compatibility reasons (find.pl, find2perl)
+ local our ($topdir, $topdev, $topino, $topmode, $topnlink);
+
+ # a symbolic link to a directory doesn't increase the link count
+ $avoid_nlink = $follow || $File::Find::dont_use_nlink;
+
+ my ($abs_dir, $Is_Dir);
+
+ Proc_Top_Item:
+ foreach my $TOP (@_) {
+ my $top_item = $TOP;
+
+ ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
+
+ if ($Is_MacOS) {
+ $top_item = ":$top_item"
+ if ( (-d _) && ( $top_item !~ /:/ ) );
+ } elsif ($^O eq 'MSWin32') {
+ $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|;
+ }
+ else {
+ $top_item =~ s|/\z|| unless $top_item eq '/';
+ }
+
+ $Is_Dir= 0;
+
+ if ($follow) {
+
+ if ($Is_MacOS) {
+ $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
+
+ if ($top_item eq $File::Find::current_dir) {
+ $abs_dir = $cwd;
+ }
+ else {
+ $abs_dir = contract_name_Mac($cwd, $top_item);
+ unless (defined $abs_dir) {
+ warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
+ next Proc_Top_Item;
+ }
+ }
+
+ }
+ else {
+ if (substr($top_item,0,1) eq '/') {
+ $abs_dir = $top_item;
+ }
+ elsif ($top_item eq $File::Find::current_dir) {
+ $abs_dir = $cwd;
+ }
+ else { # care about any ../
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ $abs_dir = contract_name("$cwd/",$top_item);
+ }
+ }
+ $abs_dir= Follow_SymLink($abs_dir);
+ unless (defined $abs_dir) {
+ if ($dangling_symlinks) {
+ if (ref $dangling_symlinks eq 'CODE') {
+ $dangling_symlinks->($top_item, $cwd);
+ } else {
+ warnings::warnif "$top_item is a dangling symbolic link\n";
+ }
+ }
+ next Proc_Top_Item;
+ }
+
+ if (-d _) {
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ _find_dir_symlnk($wanted, $abs_dir, $top_item);
+ $Is_Dir= 1;
+ }
+ }
+ else { # no follow
+ $topdir = $top_item;
+ unless (defined $topnlink) {
+ warnings::warnif "Can't stat $top_item: $!\n";
+ next Proc_Top_Item;
+ }
+ if (-d _) {
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ _find_dir($wanted, $top_item, $topnlink);
+ $Is_Dir= 1;
+ }
+ else {
+ $abs_dir= $top_item;
+ }
+ }
+
+ unless ($Is_Dir) {
+ unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
+ if ($Is_MacOS) {
+ ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
+ }
+ else {
+ ($dir,$_) = ('./', $top_item);
+ }
+ }
+
+ $abs_dir = $dir;
+ if (( $untaint ) && (is_tainted($dir) )) {
+ ( $abs_dir ) = $dir =~ m|$untaint_pat|;
+ unless (defined $abs_dir) {
+ if ($untaint_skip == 0) {
+ die "directory $dir is still tainted";
+ }
+ else {
+ next Proc_Top_Item;
+ }
+ }
+ }
+
+ unless ($no_chdir || chdir $abs_dir) {
+ warnings::warnif "Couldn't chdir $abs_dir: $!\n";
+ next Proc_Top_Item;
+ }
+
+ $name = $abs_dir . $_; # $File::Find::name
+ $_ = $name if $no_chdir;
+
+ { $wanted_callback->() }; # protect against wild "next"
+
+ }
+
+ unless ( $no_chdir ) {
+ if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
+ ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
+ unless (defined $cwd_untainted) {
+ die "insecure cwd in find(depth)";
+ }
+ $check_t_cwd = 0;
+ }
+ unless (chdir $cwd_untainted) {
+ die "Can't cd to $cwd: $!\n";
+ }
+ }
+ }
+}
+
+# API:
+# $wanted
+# $p_dir : "parent directory"
+# $nlink : what came back from the stat
+# preconditions:
+# chdir (if not no_chdir) to dir
+
+sub _find_dir($$$) {
+ my ($wanted, $p_dir, $nlink) = @_;
+ my ($CdLvl,$Level) = (0,0);
+ my @Stack;
+ my @filenames;
+ my ($subcount,$sub_nlink);
+ my $SE= [];
+ my $dir_name= $p_dir;
+ my $dir_pref;
+ my $dir_rel = $File::Find::current_dir;
+ my $tainted = 0;
+ my $no_nlink;
+
+ if ($Is_MacOS) {
+ $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
+ } elsif ($^O eq 'MSWin32') {
+ $dir_pref = ($p_dir =~ m|\w:/?$| ? $p_dir : "$p_dir/" );
+ } elsif ($^O eq 'VMS') {
+
+ # VMS is returning trailing .dir on directories
+ # and trailing . on files and symbolic links
+ # in UNIX syntax.
+ #
+
+ $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.';
+
+ $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" );
+ }
+ else {
+ $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ }
+
+ local ($dir, $name, $prune, *DIR);
+
+ unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
+ my $udir = $p_dir;
+ if (( $untaint ) && (is_tainted($p_dir) )) {
+ ( $udir ) = $p_dir =~ m|$untaint_pat|;
+ unless (defined $udir) {
+ if ($untaint_skip == 0) {
+ die "directory $p_dir is still tainted";
+ }
+ else {
+ return;
+ }
+ }
+ }
+ unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
+ warnings::warnif "Can't cd to $udir: $!\n";
+ return;
+ }
+ }
+
+ # push the starting directory
+ push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
+
+ if ($Is_MacOS) {
+ $p_dir = $dir_pref; # ensure trailing ':'
+ }
+
+ while (defined $SE) {
+ unless ($bydepth) {
+ $dir= $p_dir; # $File::Find::dir
+ $name= $dir_name; # $File::Find::name
+ $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
+ # prune may happen here
+ $prune= 0;
+ { $wanted_callback->() }; # protect against wild "next"
+ next if $prune;
+ }
+
+ # change to that directory
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ my $udir= $dir_rel;
+ if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) {
+ ( $udir ) = $dir_rel =~ m|$untaint_pat|;
+ unless (defined $udir) {
+ if ($untaint_skip == 0) {
+ if ($Is_MacOS) {
+ die "directory ($p_dir) $dir_rel is still tainted";
+ }
+ else {
+ die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
+ }
+ } else { # $untaint_skip == 1
+ next;
+ }
+ }
+ }
+ unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
+ if ($Is_MacOS) {
+ warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
+ }
+ else {
+ warnings::warnif "Can't cd to (" .
+ ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
+ }
+ next;
+ }
+ $CdLvl++;
+ }
+
+ if ($Is_MacOS) {
+ $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
+ }
+
+ $dir= $dir_name; # $File::Find::dir
+
+ # Get the list of files in the current directory.
+ unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
+ warnings::warnif "Can't opendir($dir_name): $!\n";
+ next;
+ }
+ @filenames = readdir DIR;
+ closedir(DIR);
+ @filenames = $pre_process->(@filenames) if $pre_process;
+ push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
+
+ # default: use whatever was specifid
+ # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
+ $no_nlink = $avoid_nlink;
+ # if dir has wrong nlink count, force switch to slower stat method
+ $no_nlink = 1 if ($nlink < 2);
+
+ if ($nlink == 2 && !$no_nlink) {
+ # This dir has no subdirectories.
+ for my $FN (@filenames) {
+ if ($Is_VMS) {
+ # Big hammer here - Compensate for VMS trailing . and .dir
+ # No win situation until this is changed, but this
+ # will handle the majority of the cases with breaking the fewest
+
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ }
+ next if $FN =~ $File::Find::skip_pattern;
+
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_ = ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+
+ }
+ else {
+ # This dir has subdirectories.
+ $subcount = $nlink - 2;
+
+ # HACK: insert directories at this position. so as to preserve
+ # the user pre-processed ordering of files.
+ # EG: directory traversal is in user sorted order, not at random.
+ my $stack_top = @Stack;
+
+ for my $FN (@filenames) {
+ next if $FN =~ $File::Find::skip_pattern;
+ if ($subcount > 0 || $no_nlink) {
+ # Seen all the subdirs?
+ # check for directoriness.
+ # stat is faster for a file in the current directory
+ $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
+
+ if (-d _) {
+ --$subcount;
+ $FN =~ s/\.dir\z//i if $Is_VMS;
+ # HACK: replace push to preserve dir traversal order
+ #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
+ splice @Stack, $stack_top, 0,
+ [$CdLvl,$dir_name,$FN,$sub_nlink];
+ }
+ else {
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_= ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
+ else {
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_= ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
+ }
+ }
+ continue {
+ while ( defined ($SE = pop @Stack) ) {
+ ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
+ if ($CdLvl > $Level && !$no_chdir) {
+ my $tmp;
+ if ($Is_MacOS) {
+ $tmp = (':' x ($CdLvl-$Level)) . ':';
+ }
+ elsif ($Is_VMS) {
+ $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']';
+ }
+ else {
+ $tmp = join('/',('..') x ($CdLvl-$Level));
+ }
+ die "Can't cd to $tmp from $dir_name"
+ unless chdir ($tmp);
+ $CdLvl = $Level;
+ }
+
+ if ($Is_MacOS) {
+ # $pdir always has a trailing ':', except for the starting dir,
+ # where $dir_rel eq ':'
+ $dir_name = "$p_dir$dir_rel";
+ $dir_pref = "$dir_name:";
+ }
+ elsif ($^O eq 'MSWin32') {
+ $dir_name = ($p_dir =~ m|\w:/?$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ }
+ elsif ($^O eq 'VMS') {
+ if ($p_dir =~ m/[\]>]+$/) {
+ $dir_name = $p_dir;
+ $dir_name =~ s/([\]>]+)$/.$dir_rel$1/;
+ $dir_pref = $dir_name;
+ }
+ else {
+ $dir_name = "$p_dir/$dir_rel";
+ $dir_pref = "$dir_name/";
+ }
+ }
+ else {
+ $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ }
+
+ if ( $nlink == -2 ) {
+ $name = $dir = $p_dir; # $File::Find::name / dir
+ $_ = $File::Find::current_dir;
+ $post_process->(); # End-of-directory processing
+ }
+ elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
+ $name = $dir_name;
+ if ($Is_MacOS) {
+ if ($dir_rel eq ':') { # must be the top dir, where we started
+ $name =~ s|:$||; # $File::Find::name
+ $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
+ }
+ $dir = $p_dir; # $File::Find::dir
+ $_ = ($no_chdir ? $name : $dir_rel); # $_
+ }
+ else {
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = '';
+ }
+ $dir = $p_dir;
+ $_ = ($no_chdir ? $dir_name : $dir_rel );
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
+ }
+ }
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ else {
+ push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
+ last;
+ }
+ }
+ }
+}
+
+
+# API:
+# $wanted
+# $dir_loc : absolute location of a dir
+# $p_dir : "parent directory"
+# preconditions:
+# chdir (if not no_chdir) to dir
+
+sub _find_dir_symlnk($$$) {
+ my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
+ my @Stack;
+ my @filenames;
+ my $new_loc;
+ my $updir_loc = $dir_loc; # untainted parent directory
+ my $SE = [];
+ my $dir_name = $p_dir;
+ my $dir_pref;
+ my $loc_pref;
+ my $dir_rel = $File::Find::current_dir;
+ my $byd_flag; # flag for pending stack entry if $bydepth
+ my $tainted = 0;
+ my $ok = 1;
+
+ if ($Is_MacOS) {
+ $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
+ $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
+ } else {
+ $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
+ }
+
+ local ($dir, $name, $fullname, $prune, *DIR);
+
+ unless ($no_chdir) {
+ # untaint the topdir
+ if (( $untaint ) && (is_tainted($dir_loc) )) {
+ ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted
+ # once untainted, $updir_loc is pushed on the stack (as parent directory);
+ # hence, we don't need to untaint the parent directory every time we chdir
+ # to it later
+ unless (defined $updir_loc) {
+ if ($untaint_skip == 0) {
+ die "directory $dir_loc is still tainted";
+ }
+ else {
+ return;
+ }
+ }
+ }
+ $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
+ unless ($ok) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ return;
+ }
+ }
+
+ push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
+
+ if ($Is_MacOS) {
+ $p_dir = $dir_pref; # ensure trailing ':'
+ }
+
+ while (defined $SE) {
+
+ unless ($bydepth) {
+ # change (back) to parent directory (always untainted)
+ unless ($no_chdir) {
+ unless (chdir $updir_loc) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
+ $dir= $p_dir; # $File::Find::dir
+ $name= $dir_name; # $File::Find::name
+ $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
+ $fullname= $dir_loc; # $File::Find::fullname
+ # prune may happen here
+ $prune= 0;
+ lstat($_); # make sure file tests with '_' work
+ { $wanted_callback->() }; # protect against wild "next"
+ next if $prune;
+ }
+
+ # change to that directory
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ $updir_loc = $dir_loc;
+ if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) {
+ # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir
+ ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
+ unless (defined $updir_loc) {
+ if ($untaint_skip == 0) {
+ die "directory $dir_loc is still tainted";
+ }
+ else {
+ next;
+ }
+ }
+ }
+ unless (chdir $updir_loc) {
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
+
+ if ($Is_MacOS) {
+ $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
+ }
+
+ $dir = $dir_name; # $File::Find::dir
+
+ # Get the list of files in the current directory.
+ unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
+ warnings::warnif "Can't opendir($dir_loc): $!\n";
+ next;
+ }
+ @filenames = readdir DIR;
+ closedir(DIR);
+
+ for my $FN (@filenames) {
+ if ($Is_VMS) {
+ # Big hammer here - Compensate for VMS trailing . and .dir
+ # No win situation until this is changed, but this
+ # will handle the majority of the cases with breaking the fewest.
+
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ }
+ next if $FN =~ $File::Find::skip_pattern;
+
+ # follow symbolic links / do an lstat
+ $new_loc = Follow_SymLink($loc_pref.$FN);
+
+ # ignore if invalid symlink
+ unless (defined $new_loc) {
+ if (!defined -l _ && $dangling_symlinks) {
+ if (ref $dangling_symlinks eq 'CODE') {
+ $dangling_symlinks->($FN, $dir_pref);
+ } else {
+ warnings::warnif "$dir_pref$FN is a dangling symbolic link\n";
+ }
+ }
+
+ $fullname = undef;
+ $name = $dir_pref . $FN;
+ $_ = ($no_chdir ? $name : $FN);
+ { $wanted_callback->() };
+ next;
+ }
+
+ if (-d _) {
+ if ($Is_VMS) {
+ $FN =~ s/\.dir\z//i;
+ $FN =~ s#\.$## if ($FN ne '.');
+ $new_loc =~ s/\.dir\z//i;
+ $new_loc =~ s#\.$## if ($new_loc ne '.');
+ }
+ push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
+ }
+ else {
+ $fullname = $new_loc; # $File::Find::fullname
+ $name = $dir_pref . $FN; # $File::Find::name
+ $_ = ($no_chdir ? $name : $FN); # $_
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ }
+
+ }
+ continue {
+ while (defined($SE = pop @Stack)) {
+ ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
+ if ($Is_MacOS) {
+ # $p_dir always has a trailing ':', except for the starting dir,
+ # where $dir_rel eq ':'
+ $dir_name = "$p_dir$dir_rel";
+ $dir_pref = "$dir_name:";
+ $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
+ }
+ else {
+ $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+ $dir_pref = "$dir_name/";
+ $loc_pref = "$dir_loc/";
+ }
+ if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
+ unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
+ unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
+ warnings::warnif "Can't cd to $updir_loc: $!\n";
+ next;
+ }
+ }
+ $fullname = $dir_loc; # $File::Find::fullname
+ $name = $dir_name; # $File::Find::name
+ if ($Is_MacOS) {
+ if ($dir_rel eq ':') { # must be the top dir, where we started
+ $name =~ s|:$||; # $File::Find::name
+ $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
+ }
+ $dir = $p_dir; # $File::Find::dir
+ $_ = ($no_chdir ? $name : $dir_rel); # $_
+ }
+ else {
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
+ }
+ $dir = $p_dir; # $File::Find::dir
+ $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
+ }
+ }
+
+ lstat($_); # make sure file tests with '_' work
+ { $wanted_callback->() }; # protect against wild "next"
+ }
+ else {
+ push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth;
+ last;
+ }
+ }
+ }
+}
+
+
+sub wrap_wanted {
+ my $wanted = shift;
+ if ( ref($wanted) eq 'HASH' ) {
+ unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) {
+ die 'no &wanted subroutine given';
+ }
+ if ( $wanted->{follow} || $wanted->{follow_fast}) {
+ $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
+ }
+ if ( $wanted->{untaint} ) {
+ $wanted->{untaint_pattern} = $File::Find::untaint_pattern
+ unless defined $wanted->{untaint_pattern};
+ $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
+ }
+ return $wanted;
+ }
+ elsif( ref( $wanted ) eq 'CODE' ) {
+ return { wanted => $wanted };
+ }
+ else {
+ die 'no &wanted subroutine given';
+ }
+}
+
+sub find {
+ my $wanted = shift;
+ _find_opt(wrap_wanted($wanted), @_);
+}
+
+sub finddepth {
+ my $wanted = wrap_wanted(shift);
+ $wanted->{bydepth} = 1;
+ _find_opt($wanted, @_);
+}
+
+# default
+$File::Find::skip_pattern = qr/^\.{1,2}\z/;
+$File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
+
+# These are hard-coded for now, but may move to hint files.
+if ($^O eq 'VMS') {
+ $Is_VMS = 1;
+ $File::Find::dont_use_nlink = 1;
+}
+elsif ($^O eq 'MacOS') {
+ $Is_MacOS = 1;
+ $File::Find::dont_use_nlink = 1;
+ $File::Find::skip_pattern = qr/^Icon\015\z/;
+ $File::Find::untaint_pattern = qr|^(.+)$|;
+}
+
+# this _should_ work properly on all platforms
+# where File::Find can be expected to work
+$File::Find::current_dir = File::Spec->curdir || '.';
+
+$File::Find::dont_use_nlink = 1
+ if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
+ $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^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
+# of the number of files.
+# See, e.g. hints/machten.sh for MachTen 2.2.
+unless ($File::Find::dont_use_nlink) {
+ require Config;
+ $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
+}
+
+# We need a function that checks if a scalar is tainted. Either use the
+# Scalar::Util module's tainted() function or our (slower) pure Perl
+# fallback is_tainted_pp()
+{
+ local $@;
+ eval { require Scalar::Util };
+ *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm
new file mode 100644
index 00000000000..7c6b92cf415
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Glob.pm
@@ -0,0 +1,496 @@
+package File::Glob;
+
+use strict;
+our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS,
+ $AUTOLOAD, $DEFAULT_FLAGS);
+
+use XSLoader ();
+
+@ISA = qw(Exporter);
+
+# NOTE: The glob() export is only here for compatibility with 5.6.0.
+# csh_glob() should not be used directly, unless you know what you're doing.
+
+@EXPORT_OK = qw(
+ csh_glob
+ bsd_glob
+ glob
+ GLOB_ABEND
+ GLOB_ALPHASORT
+ GLOB_ALTDIRFUNC
+ GLOB_BRACE
+ GLOB_CSH
+ GLOB_ERR
+ GLOB_ERROR
+ GLOB_LIMIT
+ GLOB_MARK
+ GLOB_NOCASE
+ GLOB_NOCHECK
+ GLOB_NOMAGIC
+ GLOB_NOSORT
+ GLOB_NOSPACE
+ GLOB_QUOTE
+ GLOB_TILDE
+);
+
+%EXPORT_TAGS = (
+ 'glob' => [ qw(
+ GLOB_ABEND
+ GLOB_ALPHASORT
+ GLOB_ALTDIRFUNC
+ GLOB_BRACE
+ GLOB_CSH
+ GLOB_ERR
+ GLOB_ERROR
+ GLOB_LIMIT
+ GLOB_MARK
+ GLOB_NOCASE
+ GLOB_NOCHECK
+ GLOB_NOMAGIC
+ GLOB_NOSORT
+ GLOB_NOSPACE
+ GLOB_QUOTE
+ GLOB_TILDE
+ glob
+ bsd_glob
+ ) ],
+);
+
+$VERSION = '1.07';
+
+sub import {
+ require Exporter;
+ my $i = 1;
+ while ($i < @_) {
+ if ($_[$i] =~ /^:(case|nocase|globally)$/) {
+ splice(@_, $i, 1);
+ $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case';
+ $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase';
+ if ($1 eq 'globally') {
+ local $^W;
+ *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
+ }
+ next;
+ }
+ ++$i;
+ }
+ goto &Exporter::import;
+}
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ if ($error) {
+ require Carp;
+ Carp::croak($error);
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+XSLoader::load 'File::Glob', $VERSION;
+
+# Preloaded methods go here.
+
+sub GLOB_ERROR {
+ return (constant('GLOB_ERROR'))[1];
+}
+
+sub GLOB_CSH () {
+ GLOB_BRACE()
+ | GLOB_NOMAGIC()
+ | GLOB_QUOTE()
+ | GLOB_TILDE()
+ | GLOB_ALPHASORT()
+}
+
+$DEFAULT_FLAGS = GLOB_CSH();
+if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) {
+ $DEFAULT_FLAGS |= GLOB_NOCASE();
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+sub bsd_glob {
+ my ($pat,$flags) = @_;
+ $flags = $DEFAULT_FLAGS if @_ < 2;
+ return doglob($pat,$flags);
+}
+
+# File::Glob::glob() is deprecated because its prototype is different from
+# CORE::glob() (use bsd_glob() instead)
+sub glob {
+ splice @_, 1; # don't pass PL_glob_index as flags!
+ goto &bsd_glob;
+}
+
+## borrowed heavily from gsar's File::DosGlob
+my %iter;
+my %entries;
+
+sub csh_glob {
+ my $pat = shift;
+ my $cxix = shift;
+ my @pat;
+
+ # glob without args defaults to $_
+ $pat = $_ unless defined $pat;
+
+ # extract patterns
+ $pat =~ s/^\s+//; # Protect against empty elements in
+ $pat =~ s/\s+$//; # things like < *.c> and <*.c >.
+ # These alone shouldn't trigger ParseWords.
+ if ($pat =~ /\s/) {
+ # XXX this is needed for compatibility with the csh
+ # implementation in Perl. Need to support a flag
+ # to disable this behavior.
+ require Text::ParseWords;
+ @pat = Text::ParseWords::parse_line('\s+',0,$pat);
+ }
+
+ # assume global context if not provided one
+ $cxix = '_G_' unless defined $cxix;
+ $iter{$cxix} = 0 unless exists $iter{$cxix};
+
+ # if we're just beginning, do it all first
+ if ($iter{$cxix} == 0) {
+ if (@pat) {
+ $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ];
+ }
+ else {
+ $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ];
+ }
+ }
+
+ # chuck it all out, quick or slow
+ if (wantarray) {
+ delete $iter{$cxix};
+ return @{delete $entries{$cxix}};
+ }
+ else {
+ if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
+ return shift @{$entries{$cxix}};
+ }
+ else {
+ # return undef for EOL
+ delete $iter{$cxix};
+ delete $entries{$cxix};
+ return undef;
+ }
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Glob - Perl extension for BSD glob routine
+
+=head1 SYNOPSIS
+
+ use File::Glob ':glob';
+
+ @list = bsd_glob('*.[ch]');
+ $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR);
+
+ if (GLOB_ERROR) {
+ # an error occurred reading $homedir
+ }
+
+ ## override the core glob (CORE::glob() does this automatically
+ ## by default anyway, since v5.6.0)
+ use File::Glob ':globally';
+ my @sources = <*.{c,h,y}>;
+
+ ## override the core glob, forcing case sensitivity
+ use File::Glob qw(:globally :case);
+ my @sources = <*.{c,h,y}>;
+
+ ## override the core glob forcing case insensitivity
+ use File::Glob qw(:globally :nocase);
+ my @sources = <*.{c,h,y}>;
+
+ ## glob on all files in home directory
+ use File::Glob ':globally';
+ my @sources = <~gnat/*>;
+
+=head1 DESCRIPTION
+
+The glob angle-bracket operator C<< <> >> is a pathname generator that
+implements the rules for file name pattern matching used by Unix-like shells
+such as the Bourne shell or C shell.
+
+File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is
+a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2").
+bsd_glob() takes a mandatory C<pattern> argument, and an optional
+C<flags> argument, and returns a list of filenames matching the
+pattern, with interpretation of the pattern modified by the C<flags>
+variable.
+
+Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob().
+Note that they don't share the same prototype--CORE::glob() only accepts
+a single argument. Due to historical reasons, CORE::glob() will also
+split its argument on whitespace, treating it as multiple patterns,
+whereas bsd_glob() considers them as one pattern.
+
+=head2 META CHARACTERS
+
+ \ Quote the next metacharacter
+ [] Character class
+ {} Multiple pattern
+ * Match any string of characters
+ ? Match any single character
+ ~ User name home directory
+
+The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to
+right order is preserved, with results of matches being sorted separately
+at a low level to preserve this order. As a special case C<{>, C<}>, and
+C<{}> are passed undisturbed.
+
+=head2 POSIX FLAGS
+
+The POSIX defined flags for bsd_glob() are:
+
+=over 4
+
+=item C<GLOB_ERR>
+
+Force bsd_glob() to return an error when it encounters a directory it
+cannot open or read. Ordinarily bsd_glob() continues to find matches.
+
+=item C<GLOB_LIMIT>
+
+Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands
+to a size bigger than the system constant C<ARG_MAX> (usually found in
+limits.h). If your system does not define this constant, bsd_glob() uses
+C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that
+order). You can inspect these values using the standard C<POSIX>
+extension.
+
+=item C<GLOB_MARK>
+
+Each pathname that is a directory that matches the pattern has a slash
+appended.
+
+=item C<GLOB_NOCASE>
+
+By default, file names are assumed to be case sensitive; this flag
+makes bsd_glob() treat case differences as not significant.
+
+=item C<GLOB_NOCHECK>
+
+If the pattern does not match any pathname, then bsd_glob() returns a list
+consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect
+is present in the pattern returned.
+
+=item C<GLOB_NOSORT>
+
+By default, the pathnames are sorted in ascending ASCII order; this
+flag prevents that sorting (speeding up bsd_glob()).
+
+=back
+
+The FreeBSD extensions to the POSIX standard are the following flags:
+
+=over 4
+
+=item C<GLOB_BRACE>
+
+Pre-process the string to expand C<{pat,pat,...}> strings like csh(1).
+The pattern '{}' is left unexpanded for historical reasons (and csh(1)
+does the same thing to ease typing of find(1) patterns).
+
+=item C<GLOB_NOMAGIC>
+
+Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not
+contain any of the special characters "*", "?" or "[". C<NOMAGIC> is
+provided to simplify implementing the historic csh(1) globbing
+behaviour and should probably not be used anywhere else.
+
+=item C<GLOB_QUOTE>
+
+Use the backslash ('\') character for quoting: every occurrence of a
+backslash followed by a character in the pattern is replaced by that
+character, avoiding any special interpretation of the character.
+(But see below for exceptions on DOSISH systems).
+
+=item C<GLOB_TILDE>
+
+Expand patterns that start with '~' to user name home directories.
+
+=item C<GLOB_CSH>
+
+For convenience, C<GLOB_CSH> is a synonym for
+C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>.
+
+=back
+
+The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD
+extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been
+implemented in the Perl version because they involve more complex
+interaction with the underlying C structures.
+
+The following flag has been added in the Perl implementation for
+csh compatibility:
+
+=over 4
+
+=item C<GLOB_ALPHASORT>
+
+If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical
+order (case does not matter) rather than in ASCII order.
+
+=back
+
+=head1 DIAGNOSTICS
+
+bsd_glob() returns a list of matching paths, possibly zero length. If an
+error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be
+set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred,
+or one of the following values otherwise:
+
+=over 4
+
+=item C<GLOB_NOSPACE>
+
+An attempt to allocate memory failed.
+
+=item C<GLOB_ABEND>
+
+The glob was stopped because an error was encountered.
+
+=back
+
+In the case where bsd_glob() has found some matching paths, but is
+interrupted by an error, it will return a list of filenames B<and>
+set &File::Glob::ERROR.
+
+Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour
+by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will
+continue processing despite those errors, unless the C<GLOB_ERR> flag is
+set.
+
+Be aware that all filenames returned from File::Glob are tainted.
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should
+probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because
+the argument to bsd_glob() isn't subjected to parsing by the C shell.
+Remember that you can use a backslash to escape things.
+
+=item *
+
+On DOSISH systems, backslash is a valid directory separator character.
+In this case, use of backslash as a quoting character (via GLOB_QUOTE)
+interferes with the use of backslash as a directory separator. The
+best (simplest, most portable) solution is to use forward slashes for
+directory separators, and backslashes for quoting. However, this does
+not match "normal practice" on these systems. As a concession to user
+expectation, therefore, backslashes (under GLOB_QUOTE) only quote the
+glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself.
+All other backslashes are passed through unchanged.
+
+=item *
+
+Win32 users should use the real slash. If you really want to use
+backslashes, consider using Sarathy's File::DosGlob, which comes with
+the standard Perl distribution.
+
+=item *
+
+Mac OS (Classic) users should note a few differences. Since
+Mac OS is not Unix, when the glob code encounters a tilde glob (e.g.
+~user) and the C<GLOB_TILDE> flag is used, it simply returns that
+pattern without doing any expansion.
+
+Glob on Mac OS is case-insensitive by default (if you don't use any
+flags). If you specify any flags at all and still want glob
+to be case-insensitive, you must include C<GLOB_NOCASE> in the flags.
+
+The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users
+should be careful about specifying relative pathnames. While a full path
+always begins with a volume name, a relative pathname should always
+begin with a ':'. If specifying a volume name only, a trailing ':' is
+required.
+
+The specification of pathnames in glob patterns adheres to the usual Mac
+OS conventions: The path separator is a colon ':', not a slash '/'. A
+full path always begins with a volume name. A relative pathname on Mac
+OS must always begin with a ':', except when specifying a file or
+directory name in the current working directory, where the leading colon
+is optional. If specifying a volume name only, a trailing ':' is
+required. Due to these rules, a glob like E<lt>*:E<gt> will find all
+mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
+all files and directories in the current directory.
+
+Note that updirs in the glob pattern are resolved before the matching begins,
+i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
+that a single trailing ':' in the pattern is ignored (unless it's a volume
+name pattern like "*HD:"), i.e. a glob like E<lt>:*:E<gt> will find both
+directories I<and> files (and not, as one might expect, only directories).
+You can, however, use the C<GLOB_MARK> flag to distinguish (without a file
+test) directory names from file names.
+
+If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended.
+Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS,
+both a leading and a trailing colon will be added, when the directory name in
+question doesn't contain any colons (e.g. 'lib' becomes ':lib:').
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc/glob>, glob(3)
+
+=head1 AUTHOR
+
+The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>,
+and is released under the artistic license. Further modifications were
+made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy
+E<lt>gsar@activestate.comE<gt>, and Thomas Wegner
+E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the
+following copyright:
+
+ Copyright (c) 1989, 1993 The Regents of the University of California.
+ All rights reserved.
+
+ This code is derived from software contributed to Berkeley by
+ Guido van Rossum.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ 3. Neither the name of the University nor the names of its contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ SUCH DAMAGE.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/File/GlobMapper.pm b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
new file mode 100644
index 00000000000..40a606309e0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
@@ -0,0 +1,679 @@
+package File::GlobMapper;
+
+use strict;
+use warnings;
+use Carp;
+
+our ($CSH_GLOB);
+
+BEGIN
+{
+ if ($] < 5.006)
+ {
+ require File::BSDGlob; import File::BSDGlob qw(:glob) ;
+ $CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
+ *globber = \&File::BSDGlob::csh_glob;
+ }
+ else
+ {
+ require File::Glob; import File::Glob qw(:glob) ;
+ $CSH_GLOB = File::Glob::GLOB_CSH() ;
+ #*globber = \&File::Glob::bsd_glob;
+ *globber = \&File::Glob::csh_glob;
+ }
+}
+
+our ($Error);
+
+our ($VERSION, @EXPORT_OK);
+$VERSION = '1.000';
+@EXPORT_OK = qw( globmap );
+
+
+our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
+$noPreBS = '(?<!\\\)' ; # no preceeding backslash
+$metachars = '.*?[](){}';
+$matchMetaRE = '[' . quotemeta($metachars) . ']';
+
+%mapping = (
+ '*' => '([^/]*)',
+ '?' => '([^/])',
+ '.' => '\.',
+ '[' => '([',
+ '(' => '(',
+ ')' => ')',
+ );
+
+%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
+
+sub globmap ($$;)
+{
+ my $inputGlob = shift ;
+ my $outputGlob = shift ;
+
+ my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_)
+ or croak "globmap: $Error" ;
+ return $obj->getFileMap();
+}
+
+sub new
+{
+ my $class = shift ;
+ my $inputGlob = shift ;
+ my $outputGlob = shift ;
+ # TODO -- flags needs to default to whatever File::Glob does
+ my $flags = shift || $CSH_GLOB ;
+ #my $flags = shift ;
+
+ $inputGlob =~ s/^\s*\<\s*//;
+ $inputGlob =~ s/\s*\>\s*$//;
+
+ $outputGlob =~ s/^\s*\<\s*//;
+ $outputGlob =~ s/\s*\>\s*$//;
+
+ my %object =
+ ( InputGlob => $inputGlob,
+ OutputGlob => $outputGlob,
+ GlobFlags => $flags,
+ Braces => 0,
+ WildCount => 0,
+ Pairs => [],
+ Sigil => '#',
+ );
+
+ my $self = bless \%object, ref($class) || $class ;
+
+ $self->_parseInputGlob()
+ or return undef ;
+
+ $self->_parseOutputGlob()
+ or return undef ;
+
+ my @inputFiles = globber($self->{InputGlob}, $flags) ;
+
+ if (GLOB_ERROR)
+ {
+ $Error = $!;
+ return undef ;
+ }
+
+ #if (whatever)
+ {
+ my $missing = grep { ! -e $_ } @inputFiles ;
+
+ if ($missing)
+ {
+ $Error = "$missing input files do not exist";
+ return undef ;
+ }
+ }
+
+ $self->{InputFiles} = \@inputFiles ;
+
+ $self->_getFiles()
+ or return undef ;
+
+ return $self;
+}
+
+sub _retError
+{
+ my $string = shift ;
+ $Error = "$string in input fileglob" ;
+ return undef ;
+}
+
+sub _unmatched
+{
+ my $delimeter = shift ;
+
+ _retError("Unmatched $delimeter");
+ return undef ;
+}
+
+sub _parseBit
+{
+ my $self = shift ;
+
+ my $string = shift ;
+
+ my $out = '';
+ my $depth = 0 ;
+
+ while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
+ {
+ $out .= quotemeta($1) ;
+ $out .= $mapping{$2} if defined $mapping{$2};
+
+ ++ $self->{WildCount} if $wildCount{$2} ;
+
+ if ($2 eq ',')
+ {
+ return _unmatched "("
+ if $depth ;
+
+ $out .= '|';
+ }
+ elsif ($2 eq '(')
+ {
+ ++ $depth ;
+ }
+ elsif ($2 eq ')')
+ {
+ return _unmatched ")"
+ if ! $depth ;
+
+ -- $depth ;
+ }
+ elsif ($2 eq '[')
+ {
+ # TODO -- quotemeta & check no '/'
+ # TODO -- check for \] & other \ within the []
+ $string =~ s#(.*?\])##
+ or return _unmatched "[" ;
+ $out .= "$1)" ;
+ }
+ elsif ($2 eq ']')
+ {
+ return _unmatched "]" ;
+ }
+ elsif ($2 eq '{' || $2 eq '}')
+ {
+ return _retError "Nested {} not allowed" ;
+ }
+ }
+
+ $out .= quotemeta $string;
+
+ return _unmatched "("
+ if $depth ;
+
+ return $out ;
+}
+
+sub _parseInputGlob
+{
+ my $self = shift ;
+
+ my $string = $self->{InputGlob} ;
+ my $inGlob = '';
+
+ # Multiple concatenated *'s don't make sense
+ #$string =~ s#\*\*+#*# ;
+
+ # TODO -- Allow space to delimit patterns?
+ #my @strings = split /\s+/, $string ;
+ #for my $str (@strings)
+ my $out = '';
+ my $depth = 0 ;
+
+ while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
+ {
+ $out .= quotemeta($1) ;
+ $out .= $mapping{$2} if defined $mapping{$2};
+ ++ $self->{WildCount} if $wildCount{$2} ;
+
+ if ($2 eq '(')
+ {
+ ++ $depth ;
+ }
+ elsif ($2 eq ')')
+ {
+ return _unmatched ")"
+ if ! $depth ;
+
+ -- $depth ;
+ }
+ elsif ($2 eq '[')
+ {
+ # TODO -- quotemeta & check no '/' or '(' or ')'
+ # TODO -- check for \] & other \ within the []
+ $string =~ s#(.*?\])##
+ or return _unmatched "[";
+ $out .= "$1)" ;
+ }
+ elsif ($2 eq ']')
+ {
+ return _unmatched "]" ;
+ }
+ elsif ($2 eq '}')
+ {
+ return _unmatched "}" ;
+ }
+ elsif ($2 eq '{')
+ {
+ # TODO -- check no '/' within the {}
+ # TODO -- check for \} & other \ within the {}
+
+ my $tmp ;
+ unless ( $string =~ s/(.*?)$noPreBS\}//)
+ {
+ return _unmatched "{";
+ }
+ #$string =~ s#(.*?)\}##;
+
+ #my $alt = join '|',
+ # map { quotemeta $_ }
+ # split "$noPreBS,", $1 ;
+ my $alt = $self->_parseBit($1);
+ defined $alt or return 0 ;
+ $out .= "($alt)" ;
+
+ ++ $self->{Braces} ;
+ }
+ }
+
+ return _unmatched "("
+ if $depth ;
+
+ $out .= quotemeta $string ;
+
+
+ $self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
+ $self->{InputPattern} = $out ;
+
+ #print "# INPUT '$self->{InputGlob}' => '$out'\n";
+
+ return 1 ;
+
+}
+
+sub _parseOutputGlob
+{
+ my $self = shift ;
+
+ my $string = $self->{OutputGlob} ;
+ my $maxwild = $self->{WildCount};
+
+ if ($self->{GlobFlags} & GLOB_TILDE)
+ #if (1)
+ {
+ $string =~ s{
+ ^ ~ # find a leading tilde
+ ( # save this in $1
+ [^/] # a non-slash character
+ * # repeated 0 or more times (0 means me)
+ )
+ }{
+ $1
+ ? (getpwnam($1))[7]
+ : ( $ENV{HOME} || $ENV{LOGDIR} )
+ }ex;
+
+ }
+
+ # max #1 must be == to max no of '*' in input
+ while ( $string =~ m/#(\d)/g )
+ {
+ croak "Max wild is #$maxwild, you tried #$1"
+ if $1 > $maxwild ;
+ }
+
+ my $noPreBS = '(?<!\\\)' ; # no preceeding backslash
+ #warn "noPreBS = '$noPreBS'\n";
+
+ #$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
+ $string =~ s/${noPreBS}#(\d)/\${$1}/g;
+ $string =~ s#${noPreBS}\*#\${inFile}#g;
+ $string = '"' . $string . '"';
+
+ #print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
+ $self->{OutputPattern} = $string ;
+
+ return 1 ;
+}
+
+sub _getFiles
+{
+ my $self = shift ;
+
+ my %outInMapping = ();
+ my %inFiles = () ;
+
+ foreach my $inFile (@{ $self->{InputFiles} })
+ {
+ next if $inFiles{$inFile} ++ ;
+
+ my $outFile = $inFile ;
+
+ if ( $inFile =~ m/$self->{InputPattern}/ )
+ {
+ no warnings 'uninitialized';
+ eval "\$outFile = $self->{OutputPattern};" ;
+
+ if (defined $outInMapping{$outFile})
+ {
+ $Error = "multiple input files map to one output file";
+ return undef ;
+ }
+ $outInMapping{$outFile} = $inFile;
+ push @{ $self->{Pairs} }, [$inFile, $outFile];
+ }
+ }
+
+ return 1 ;
+}
+
+sub getFileMap
+{
+ my $self = shift ;
+
+ return $self->{Pairs} ;
+}
+
+sub getHash
+{
+ my $self = shift ;
+
+ return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::GlobMapper - Extend File Glob to Allow Input and Output Files
+
+=head1 SYNOPSIS
+
+ use File::GlobMapper qw( globmap );
+
+ my $aref = globmap $input => $output
+ or die $File::GlobMapper::Error ;
+
+ my $gm = new File::GlobMapper $input => $output
+ or die $File::GlobMapper::Error ;
+
+
+=head1 DESCRIPTION
+
+This module needs Perl5.005 or better.
+
+This module takes the existing C<File::Glob> module as a starting point and
+extends it to allow new filenames to be derived from the files matched by
+C<File::Glob>.
+
+This can be useful when carrying out batch operations on multiple files that
+have both an input filename and output filename and the output file can be
+derived from the input filename. Examples of operations where this can be
+useful include, file renaming, file copying and file compression.
+
+
+=head2 Behind The Scenes
+
+To help explain what C<File::GlobMapper> does, consider what code you
+would write if you wanted to rename all files in the current directory
+that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
+current directory
+
+ alpha.tar.gz
+ beta.tar.gz
+ gamma.tar.gz
+
+and they need renamed to this
+
+ alpha.tgz
+ beta.tgz
+ gamma.tgz
+
+Below is a possible implementation of a script to carry out the rename
+(error cases have been omitted)
+
+ foreach my $old ( glob "*.tar.gz" )
+ {
+ my $new = $old;
+ $new =~ s#(.*)\.tar\.gz$#$1.tgz# ;
+
+ rename $old => $new
+ or die "Cannot rename '$old' to '$new': $!\n;
+ }
+
+Notice that a file glob pattern C<*.tar.gz> was used to match the
+C<.tar.gz> files, then a fairly similar regular expression was used in
+the substitute to allow the new filename to be created.
+
+Given that the file glob is just a cut-down regular expression and that it
+has already done a lot of the hard work in pattern matching the filenames,
+wouldn't it be handy to be able to use the patterns in the fileglob to
+drive the new filename?
+
+Well, that's I<exactly> what C<File::GlobMapper> does.
+
+Here is same snippet of code rewritten using C<globmap>
+
+ for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' )
+ {
+ my ($from, $to) = @$pair;
+ rename $from => $to
+ or die "Cannot rename '$old' to '$new': $!\n;
+ }
+
+So how does it work?
+
+Behind the scenes the C<globmap> function does a combination of a
+file glob to match existing filenames followed by a substitute
+to create the new filenames.
+
+Notice how both parameters to C<globmap> are strings that are delimited by <>.
+This is done to make them look more like file globs - it is just syntactic
+sugar, but it can be handy when you want the strings to be visually
+distinctive. The enclosing <> are optional, so you don't have to use them - in
+fact the first thing globmap will do is remove these delimiters if they are
+present.
+
+The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
+Once the enclosing "< ... >" is removed, this is passed (more or
+less) unchanged to C<File::Glob> to carry out a file match.
+
+Next the fileglob C<*.tar.gz> is transformed behind the scenes into a
+full Perl regular expression, with the additional step of wrapping each
+transformed wildcard metacharacter sequence in parenthesis.
+
+In this case the input fileglob C<*.tar.gz> will be transformed into
+this Perl regular expression
+
+ ([^/]*)\.tar\.gz
+
+Wrapping with parenthesis allows the wildcard parts of the Input File
+Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>,
+the I<Output File Glob>. This parameter operates just like the replacement
+part of a substitute command. The difference is that the C<#1> syntax
+is used to reference sub-patterns matched in the input fileglob, rather
+than the C<$1> syntax that is used with perl regular expressions. In
+this case C<#1> is used to refer to the text matched by the C<*> in the
+Input File Glob. This makes it easier to use this module where the
+parameters to C<globmap> are typed at the command line.
+
+The final step involves passing each filename matched by the C<*.tar.gz>
+file glob through the derived Perl regular expression in turn and
+expanding the output fileglob using it.
+
+The end result of all this is a list of pairs of filenames. By default
+that is what is returned by C<globmap>. In this example the data structure
+returned will look like this
+
+ ( ['alpha.tar.gz' => 'alpha.tgz'],
+ ['beta.tar.gz' => 'beta.tgz' ],
+ ['gamma.tar.gz' => 'gamma.tgz']
+ )
+
+
+Each pair is an array reference with two elements - namely the I<from>
+filename, that C<File::Glob> has matched, and a I<to> filename that is
+derived from the I<from> filename.
+
+
+
+=head2 Limitations
+
+C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
+solve all filename mapping operations. Under the hood C<File::Glob> (or for
+older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
+will never have the flexibility of full Perl regular expression.
+
+=head2 Input File Glob
+
+The syntax for an Input FileGlob is identical to C<File::Glob>, except
+for the following
+
+=over 5
+
+=item 1.
+
+No nested {}
+
+=item 2.
+
+Whitespace does not delimit fileglobs.
+
+=item 3.
+
+The use of parenthesis can be used to capture parts of the input filename.
+
+=item 4.
+
+If an Input glob matches the same file more than once, only the first
+will be used.
+
+=back
+
+The syntax
+
+=over 5
+
+=item B<~>
+
+=item B<~user>
+
+
+=item B<.>
+
+Matches a literal '.'.
+Equivalent to the Perl regular expression
+
+ \.
+
+=item B<*>
+
+Matches zero or more characters, except '/'. Equivalent to the Perl
+regular expression
+
+ [^/]*
+
+=item B<?>
+
+Matches zero or one character, except '/'. Equivalent to the Perl
+regular expression
+
+ [^/]?
+
+=item B<\>
+
+Backslash is used, as usual, to escape the next character.
+
+=item B<[]>
+
+Character class.
+
+=item B<{,}>
+
+Alternation
+
+=item B<()>
+
+Capturing parenthesis that work just like perl
+
+=back
+
+Any other character it taken literally.
+
+=head2 Output File Glob
+
+The Output File Glob is a normal string, with 2 glob-like features.
+
+The first is the '*' metacharacter. This will be replaced by the complete
+filename matched by the input file glob. So
+
+ *.c *.Z
+
+The second is
+
+Output FileGlobs take the
+
+=over 5
+
+=item "*"
+
+The "*" character will be replaced with the complete input filename.
+
+=item #1
+
+Patterns of the form /#\d/ will be replaced with the
+
+=back
+
+=head2 Returned Data
+
+
+=head1 EXAMPLES
+
+=head2 A Rename script
+
+Below is a simple "rename" script that uses C<globmap> to determine the
+source and destination filenames.
+
+ use File::GlobMapper qw(globmap) ;
+ use File::Copy;
+
+ die "rename: Usage rename 'from' 'to'\n"
+ unless @ARGV == 2 ;
+
+ my $fromGlob = shift @ARGV;
+ my $toGlob = shift @ARGV;
+
+ my $pairs = globmap($fromGlob, $toGlob)
+ or die $File::GlobMapper::Error;
+
+ for my $pair (@$pairs)
+ {
+ my ($from, $to) = @$pair;
+ move $from => $to ;
+ }
+
+
+
+Here is an example that renames all c files to cpp.
+
+ $ rename '*.c' '#1.cpp'
+
+=head2 A few example globmaps
+
+Below are a few examples of globmaps
+
+To copy all your .c file to a backup directory
+
+ '</my/home/*.c>' '</my/backup/#1.c>'
+
+If you want to compress all
+
+ '</my/home/*.[ch]>' '<*.gz>'
+
+To uncompress
+
+ '</my/home/*.[ch].gz>' '</my/home/#1.#2>'
+
+=head1 SEE ALSO
+
+L<File::Glob|File::Glob>
+
+=head1 AUTHOR
+
+The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 Paul Marquess. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/File/Path.pm b/Master/tlpkg/tlperl/lib/File/Path.pm
new file mode 100644
index 00000000000..5a9a88e4020
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Path.pm
@@ -0,0 +1,981 @@
+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.08_01';
+@ISA = qw(Exporter);
+@EXPORT = qw(mkpath rmtree);
+@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};
+ $arg->{owner} = delete $arg->{user} if exists $arg->{user};
+ $arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
+ if (exists $arg->{owner} and $arg->{owner} =~ /\D/) {
+ my $uid = (getpwnam $arg->{owner})[2];
+ if (defined $uid) {
+ $arg->{owner} = $uid;
+ }
+ else {
+ _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed");
+ delete $arg->{owner};
+ }
+ }
+ if (exists $arg->{group} and $arg->{group} =~ /\D/) {
+ my $gid = (getgrnam $arg->{group})[2];
+ if (defined $gid) {
+ $arg->{group} = $gid;
+ }
+ else {
+ _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed");
+ delete $arg->{group};
+ }
+ }
+ if (exists $arg->{owner} and not exists $arg->{group}) {
+ $arg->{group} = -1; # chown will leave group unchanged
+ }
+ if (exists $arg->{group} and not exists $arg->{owner}) {
+ $arg->{owner} = -1; # chown will leave owner unchanged
+ }
+ $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);
+ if (exists $arg->{owner}) {
+ # NB: $arg->{group} guaranteed to be set during initialisation
+ if (!chown $arg->{owner}, $arg->{group}, $path) {
+ _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}");
+ }
+ }
+ }
+ 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, +@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::vmspath(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;
+ }
+
+ @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.08 of File::Path, released
+2009-10-04.
+
+=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.
+
+=item owner => $owner
+
+=item user => $owner
+
+=item uid => $owner
+
+If present, will cause any created directory to be owned by C<$owner>.
+If the value is numeric, it will be interpreted as a uid, otherwise
+as username is assumed. An error will be issued if the username cannot be
+mapped to a uid, or the uid does not exist, or the process lacks the
+privileges to change ownership.
+
+Ownwership of directories that already exist will not be changed.
+
+C<user> and C<uid> are aliases of C<owner>.
+
+=item group => $group
+
+If present, will cause any created directory to be owned by the group C<$group>.
+If the value is numeric, it will be interpreted as a gid, otherwise
+as group name is assumed. An error will be issued if the group name cannot be
+mapped to a gid, or the gid does not exist, or the process lacks the
+privileges to change group ownership.
+
+Group ownwership of directories that already exist will not be changed.
+
+ make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
+
+=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 API CHANGES
+
+The API was changed in the 2.0 branch. For a time, C<mkpath> and
+C<rmtree> tried, unsuccessfully, to deal with the two different
+calling mechanisms. This approach was considered a failure.
+
+The new semantics are now only available with C<make_path> and
+C<remove_tree>. The old semantics are only available through
+C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
+to at least 2.08 in order to avoid surprises.
+
+=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).
+
+=item unable to map [owner] to a uid, ownership not changed");
+
+C<make_path> was instructed to give the ownership of created
+directories to the symbolic name [owner], but C<getpwnam> did
+not return the corresponding numeric uid. The directory will
+be created, but ownership will not be changed.
+
+=item unable to map [group] to a gid, group ownership not changed
+
+C<make_path> was instructed to give the group ownership of created
+directories to the symbolic name [group], but C<getgrnam> did
+not return the corresponding numeric gid. The directory will
+be created, but group ownership will not be changed.
+
+=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@landgren.net>>.
+
+=head1 COPYRIGHT
+
+This module is copyright (C) Charles Bailey, Tim Bunce and
+David Landgren 1995-2009. 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
diff --git a/Master/tlpkg/tlperl/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm
new file mode 100644
index 00000000000..9caf4eba0d0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec.pm
@@ -0,0 +1,336 @@
+package File::Spec;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+$VERSION = '3.31_01';
+$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";
+@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@cpan.org> >>.
+
+The vast majority of the code was written by
+Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
+Andy Dougherty C<< <doughera@lafayette.edu> >>,
+Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
+Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
+VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
+OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
+Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
+Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
+abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
+modified by Barrie Slaymaker C<< <barries@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
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm
new file mode 100644
index 00000000000..050a1bb2b77
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm
@@ -0,0 +1,155 @@
+package File::Spec::Cygwin;
+
+use strict;
+use vars qw(@ISA $VERSION);
+require File::Spec::Unix;
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+@ISA = qw(File::Spec::Unix);
+
+=head1 NAME
+
+File::Spec::Cygwin - methods for Cygwin file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::Cygwin; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+This module is still in beta. Cygwin-knowledgeable folks are invited
+to offer patches and suggestions.
+
+=cut
+
+=pod
+
+=over 4
+
+=item canonpath
+
+Any C<\> (backslashes) are converted to C</> (forward slashes),
+and then File::Spec::Unix canonpath() is called on the result.
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ return unless defined $path;
+
+ $path =~ s|\\|/|g;
+
+ # Handle network path names beginning with double slash
+ my $node = '';
+ if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
+ $node = $1;
+ }
+ return $node . $self->SUPER::canonpath($path);
+}
+
+sub catdir {
+ my $self = shift;
+ return unless @_;
+
+ # Don't create something that looks like a //network/path
+ if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
+ shift;
+ return $self->SUPER::catdir('', @_);
+ }
+
+ $self->SUPER::catdir(@_);
+}
+
+=pod
+
+=item file_name_is_absolute
+
+True is returned if the file name begins with C<drive_letter:>,
+and if not, File::Spec::Unix file_name_is_absolute() is called.
+
+=cut
+
+
+sub file_name_is_absolute {
+ my ($self,$file) = @_;
+ return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
+ return $self->SUPER::file_name_is_absolute($file);
+}
+
+=item tmpdir (override)
+
+Returns a string representation of the first existing directory
+from the following list:
+
+ $ENV{TMPDIR}
+ /tmp
+ $ENV{'TMP'}
+ $ENV{'TEMP'}
+ C:/temp
+
+Since Perl 5.8.0, if running under taint mode, and if the environment
+variables are tainted, they are not used.
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+ return $tmpdir if defined $tmpdir;
+ $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
+}
+
+=item case_tolerant
+
+Override Unix. Cygwin case-tolerance depends on managed mount settings and
+as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
+indicating the case significance when comparing file specifications.
+Default: 1
+
+=cut
+
+sub case_tolerant {
+ return 1 unless $^O eq 'cygwin'
+ and defined &Cygwin::mount_flags;
+
+ my $drive = shift;
+ if (! $drive) {
+ my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
+ my $prefix = pop(@flags);
+ if (! $prefix || $prefix eq 'cygdrive') {
+ $drive = '/cygdrive/c';
+ } elsif ($prefix eq '/') {
+ $drive = '/c';
+ } else {
+ $drive = "$prefix/c";
+ }
+ }
+ my $mntopts = Cygwin::mount_flags($drive);
+ if ($mntopts and ($mntopts =~ /,managed/)) {
+ return 0;
+ }
+ eval { require Win32API::File; } or return 1;
+ my $osFsType = "\0"x256;
+ my $osVolName = "\0"x256;
+ my $ouFsFlags = 0;
+ Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
+ if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
+ else { return 1; }
+}
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004,2007 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
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm
new file mode 100644
index 00000000000..54ff667c52f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm
@@ -0,0 +1,79 @@
+package File::Spec::Epoc;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+require File::Spec::Unix;
+@ISA = qw(File::Spec::Unix);
+
+=head1 NAME
+
+File::Spec::Epoc - methods for Epoc file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::Epoc; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+This package is still work in progress ;-)
+
+=cut
+
+sub case_tolerant {
+ return 1;
+}
+
+=pod
+
+=over 4
+
+=item canonpath()
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=back
+
+=cut
+
+sub canonpath {
+ my ($self,$path) = @_;
+ return unless defined $path;
+
+ $path =~ s|/+|/|g; # xx////xx -> xx/xx
+ $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
+ $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
+ $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
+ $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
+ return $path;
+}
+
+=pod
+
+=head1 AUTHOR
+
+o.flebbe@gmx.de
+
+=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.
+
+=head1 SEE ALSO
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm
new file mode 100644
index 00000000000..e7becc7cfae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm
@@ -0,0 +1,110 @@
+package File::Spec::Functions;
+
+use File::Spec;
+use strict;
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ canonpath
+ catdir
+ catfile
+ curdir
+ rootdir
+ updir
+ no_upwards
+ file_name_is_absolute
+ path
+);
+
+@EXPORT_OK = qw(
+ devnull
+ tmpdir
+ splitpath
+ splitdir
+ catpath
+ abs2rel
+ rel2abs
+ case_tolerant
+);
+
+%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
+
+foreach my $meth (@EXPORT, @EXPORT_OK) {
+ my $sub = File::Spec->can($meth);
+ no strict 'refs';
+ *{$meth} = sub {&$sub('File::Spec', @_)};
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+File::Spec::Functions - portably perform operations on file names
+
+=head1 SYNOPSIS
+
+ use File::Spec::Functions;
+ $x = catfile('a','b');
+
+=head1 DESCRIPTION
+
+This module exports convenience functions for all of the class methods
+provided by File::Spec.
+
+For a reference of available functions, please consult L<File::Spec::Unix>,
+which contains the entire set, and which is inherited by the modules for
+other platforms. For further information, please see L<File::Spec::Mac>,
+L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
+
+=head2 Exports
+
+The following functions are exported by default.
+
+ canonpath
+ catdir
+ catfile
+ curdir
+ rootdir
+ updir
+ no_upwards
+ file_name_is_absolute
+ path
+
+
+The following functions are exported only by request.
+
+ devnull
+ tmpdir
+ splitpath
+ splitdir
+ catpath
+ abs2rel
+ rel2abs
+ case_tolerant
+
+All the functions may be imported using the C<:ALL> tag.
+
+=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.
+
+=head1 SEE ALSO
+
+File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
+File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm
new file mode 100644
index 00000000000..8b47470d6b3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm
@@ -0,0 +1,781 @@
+package File::Spec::Mac;
+
+use strict;
+use vars qw(@ISA $VERSION);
+require File::Spec::Unix;
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+@ISA = qw(File::Spec::Unix);
+
+my $macfiles;
+if ($^O eq 'MacOS') {
+ $macfiles = eval { require Mac::Files };
+}
+
+sub case_tolerant { 1 }
+
+
+=head1 NAME
+
+File::Spec::Mac - File::Spec for Mac OS (Classic)
+
+=head1 SYNOPSIS
+
+ require File::Spec::Mac; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+Methods for manipulating file specifications.
+
+=head1 METHODS
+
+=over 2
+
+=item canonpath
+
+On Mac OS, there's nothing to be done. Returns what it's given.
+
+=cut
+
+sub canonpath {
+ my ($self,$path) = @_;
+ return $path;
+}
+
+=item catdir()
+
+Concatenate two or more directory names to form a path separated by colons
+(":") ending with a directory. Resulting paths are B<relative> by default,
+but can be forced to be absolute (but avoid this, see below). Automatically
+puts a trailing ":" on the end of the complete path, because that's what's
+done in MacPerl's environment and helps to distinguish a file path from a
+directory path.
+
+B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
+path is relative by default and I<not> absolute. This decision was made due
+to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
+on all other operating systems, it will now also follow this convention on Mac
+OS. Note that this may break some existing scripts.
+
+The intended purpose of this routine is to concatenate I<directory names>.
+But because of the nature of Macintosh paths, some additional possibilities
+are allowed to make using this routine give reasonable results for some
+common situations. In other words, you are also allowed to concatenate
+I<paths> instead of directory names (strictly speaking, a string like ":a"
+is a path, but not a name, since it contains a punctuation character ":").
+
+So, beside calls like
+
+ catdir("a") = ":a:"
+ catdir("a","b") = ":a:b:"
+ catdir() = "" (special case)
+
+calls like the following
+
+ catdir(":a:") = ":a:"
+ catdir(":a","b") = ":a:b:"
+ catdir(":a:","b") = ":a:b:"
+ catdir(":a:",":b:") = ":a:b:"
+ catdir(":") = ":"
+
+are allowed.
+
+Here are the rules that are used in C<catdir()>; note that we try to be as
+compatible as possible to Unix:
+
+=over 2
+
+=item 1.
+
+The resulting path is relative by default, i.e. the resulting path will have a
+leading colon.
+
+=item 2.
+
+A trailing colon is added automatically to the resulting path, to denote a
+directory.
+
+=item 3.
+
+Generally, each argument has one leading ":" and one trailing ":"
+removed (if any). They are then joined together by a ":". Special
+treatment applies for arguments denoting updir paths like "::lib:",
+see (4), or arguments consisting solely of colons ("colon paths"),
+see (5).
+
+=item 4.
+
+When an updir path like ":::lib::" is passed as argument, the number
+of directories to climb up is handled correctly, not removing leading
+or trailing colons when necessary. E.g.
+
+ catdir(":::a","::b","c") = ":::a::b:c:"
+ catdir(":::a::","::b","c") = ":::a:::b:c:"
+
+=item 5.
+
+Adding a colon ":" or empty string "" to a path at I<any> position
+doesn't alter the path, i.e. these arguments are ignored. (When a ""
+is passed as the first argument, it has a special meaning, see
+(6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
+while an empty string "" is generally ignored (see
+C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
+(updir), and a ":::" is handled like a "../.." etc. E.g.
+
+ catdir("a",":",":","b") = ":a:b:"
+ catdir("a",":","::",":b") = ":a::b:"
+
+=item 6.
+
+If the first argument is an empty string "" or is a volume name, i.e. matches
+the pattern /^[^:]+:/, the resulting path is B<absolute>.
+
+=item 7.
+
+Passing an empty string "" as the first argument to C<catdir()> is
+like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
+
+ catdir("","a","b") is the same as
+
+ catdir(rootdir(),"a","b").
+
+This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
+C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
+volume, which is the closest in concept to Unix' "/". This should help
+to run existing scripts originally written for Unix.
+
+=item 8.
+
+For absolute paths, some cleanup is done, to ensure that the volume
+name isn't immediately followed by updirs. This is invalid, because
+this would go beyond "root". Generally, these cases are handled like
+their Unix counterparts:
+
+ Unix:
+ Unix->catdir("","") = "/"
+ Unix->catdir("",".") = "/"
+ Unix->catdir("","..") = "/" # can't go beyond root
+ Unix->catdir("",".","..","..","a") = "/a"
+ Mac:
+ Mac->catdir("","") = rootdir() # (e.g. "HD:")
+ Mac->catdir("",":") = rootdir()
+ Mac->catdir("","::") = rootdir() # can't go beyond root
+ Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:")
+
+However, this approach is limited to the first arguments following
+"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
+arguments that move up the directory tree, an invalid path going
+beyond root can be created.
+
+=back
+
+As you've seen, you can force C<catdir()> to create an absolute path
+by passing either an empty string or a path that begins with a volume
+name as the first argument. However, you are strongly encouraged not
+to do so, since this is done only for backward compatibility. Newer
+versions of File::Spec come with a method called C<catpath()> (see
+below), that is designed to offer a portable solution for the creation
+of absolute paths. It takes volume, directory and file portions and
+returns an entire path. While C<catdir()> is still suitable for the
+concatenation of I<directory names>, you are encouraged to use
+C<catpath()> to concatenate I<volume names> and I<directory
+paths>. E.g.
+
+ $dir = File::Spec->catdir("tmp","sources");
+ $abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
+
+yields
+
+ "MacintoshHD:tmp:sources:" .
+
+=cut
+
+sub catdir {
+ my $self = shift;
+ return '' unless @_;
+ my @args = @_;
+ my $first_arg;
+ my $relative;
+
+ # take care of the first argument
+
+ if ($args[0] eq '') { # absolute path, rootdir
+ shift @args;
+ $relative = 0;
+ $first_arg = $self->rootdir;
+
+ } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
+ $relative = 0;
+ $first_arg = shift @args;
+ # add a trailing ':' if need be (may be it's a path like HD:dir)
+ $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
+
+ } else { # relative path
+ $relative = 1;
+ if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
+ # updir colon path ('::', ':::' etc.), don't shift
+ $first_arg = ':';
+ } elsif ($args[0] eq ':') {
+ $first_arg = shift @args;
+ } else {
+ # add a trailing ':' if need be
+ $first_arg = shift @args;
+ $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
+ }
+ }
+
+ # For all other arguments,
+ # (a) ignore arguments that equal ':' or '',
+ # (b) handle updir paths specially:
+ # '::' -> concatenate '::'
+ # '::' . '::' -> concatenate ':::' etc.
+ # (c) add a trailing ':' if need be
+
+ my $result = $first_arg;
+ while (@args) {
+ my $arg = shift @args;
+ unless (($arg eq '') || ($arg eq ':')) {
+ if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
+ my $updir_count = length($arg) - 1;
+ while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
+ $arg = shift @args;
+ $updir_count += (length($arg) - 1);
+ }
+ $arg = (':' x $updir_count);
+ } else {
+ $arg =~ s/^://s; # remove a leading ':' if any
+ $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
+ }
+ $result .= $arg;
+ }#unless
+ }
+
+ if ( ($relative) && ($result !~ /^:/) ) {
+ # add a leading colon if need be
+ $result = ":$result";
+ }
+
+ unless ($relative) {
+ # remove updirs immediately following the volume name
+ $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
+ }
+
+ return $result;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename. Resulting paths are B<relative>
+by default, but can be forced to be absolute (but avoid this).
+
+B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
+resulting path is relative by default and I<not> absolute. This
+decision was made due to portability reasons. Since
+C<File::Spec-E<gt>catfile()> returns relative paths on all other
+operating systems, it will now also follow this convention on Mac OS.
+Note that this may break some existing scripts.
+
+The last argument is always considered to be the file portion. Since
+C<catfile()> uses C<catdir()> (see above) for the concatenation of the
+directory portions (if any), the following with regard to relative and
+absolute paths is true:
+
+ catfile("") = ""
+ catfile("file") = "file"
+
+but
+
+ catfile("","") = rootdir() # (e.g. "HD:")
+ catfile("","file") = rootdir() . file # (e.g. "HD:file")
+ catfile("HD:","file") = "HD:file"
+
+This means that C<catdir()> is called only when there are two or more
+arguments, as one might expect.
+
+Note that the leading ":" is removed from the filename, so that
+
+ catfile("a","b","file") = ":a:b:file" and
+
+ catfile("a","b",":file") = ":a:b:file"
+
+give the same answer.
+
+To concatenate I<volume names>, I<directory paths> and I<filenames>,
+you are encouraged to use C<catpath()> (see below).
+
+=cut
+
+sub catfile {
+ my $self = shift;
+ return '' unless @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $file =~ s/^://s;
+ return $dir.$file;
+}
+
+=item curdir
+
+Returns a string representing the current directory. On Mac OS, this is ":".
+
+=cut
+
+sub curdir {
+ return ":";
+}
+
+=item devnull
+
+Returns a string representing the null device. On Mac OS, this is "Dev:Null".
+
+=cut
+
+sub devnull {
+ return "Dev:Null";
+}
+
+=item rootdir
+
+Returns a string representing the root directory. Under MacPerl,
+returns the name of the startup volume, since that's the closest in
+concept, although other volumes aren't rooted there. The name has a
+trailing ":", because that's the correct specification for a volume
+name on Mac OS.
+
+If Mac::Files could not be loaded, the empty string is returned.
+
+=cut
+
+sub rootdir {
+#
+# There's no real root directory on Mac OS. The name of the startup
+# volume is returned, since that's the closest in concept.
+#
+ return '' unless $macfiles;
+ my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
+ &Mac::Files::kSystemFolderType);
+ $system =~ s/:.*\Z(?!\n)/:/s;
+ return $system;
+}
+
+=item tmpdir
+
+Returns the contents of $ENV{TMPDIR}, if that directory exits or the
+current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
+contain a path like "MacintoshHD:Temporary Items:", which is a hidden
+directory on your startup volume.
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+ return $tmpdir if defined $tmpdir;
+ $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} );
+}
+
+=item updir
+
+Returns a string representing the parent directory. On Mac OS, this is "::".
+
+=cut
+
+sub updir {
+ return "::";
+}
+
+=item file_name_is_absolute
+
+Takes as argument a path and returns true, if it is an absolute path.
+If the path has a leading ":", it's a relative path. Otherwise, it's an
+absolute path, unless the path doesn't contain any colons, i.e. it's a name
+like "a". In this particular case, the path is considered to be relative
+(i.e. it is considered to be a filename). Use ":" in the appropriate place
+in the path if you want to distinguish unambiguously. As a special case,
+the filename '' is always considered to be absolute. Note that with version
+1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
+
+E.g.
+
+ File::Spec->file_name_is_absolute("a"); # false (relative)
+ File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
+ File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute)
+ File::Spec->file_name_is_absolute(""); # true (absolute)
+
+
+=cut
+
+sub file_name_is_absolute {
+ my ($self,$file) = @_;
+ if ($file =~ /:/) {
+ return (! ($file =~ m/^:/s) );
+ } elsif ( $file eq '' ) {
+ return 1 ;
+ } else {
+ return 0; # i.e. a file like "a"
+ }
+}
+
+=item path
+
+Returns the null list for the MacPerl application, since the concept is
+usually meaningless under Mac OS. But if you're using the MacPerl tool under
+MPW, it gives back $ENV{Commands} suitably split, as is done in
+:lib:ExtUtils:MM_Mac.pm.
+
+=cut
+
+sub path {
+#
+# The concept is meaningless under the MacPerl application.
+# Under MPW, it has a meaning.
+#
+ return unless exists $ENV{Commands};
+ return split(/,/, $ENV{Commands});
+}
+
+=item splitpath
+
+ ($volume,$directories,$file) = File::Spec->splitpath( $path );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path into volume, directory, and filename portions.
+
+On Mac OS, assumes that the last part of the path is a filename unless
+$no_file is true or a trailing separator ":" is present.
+
+The volume portion is always returned with a trailing ":". The directory portion
+is always returned with a leading (to denote a relative path) and a trailing ":"
+(to denote a directory). The file portion is always returned I<without> a leading ":".
+Empty portions are returned as empty string ''.
+
+The results can be passed to C<catpath()> to get back a path equivalent to
+(usually identical to) the original path.
+
+
+=cut
+
+sub splitpath {
+ my ($self,$path, $nofile) = @_;
+ my ($volume,$directory,$file);
+
+ if ( $nofile ) {
+ ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
+ }
+ else {
+ $path =~
+ m|^( (?: [^:]+: )? )
+ ( (?: .*: )? )
+ ( .* )
+ |xs;
+ $volume = $1;
+ $directory = $2;
+ $file = $3;
+ }
+
+ $volume = '' unless defined($volume);
+ $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
+ if ($directory) {
+ # Make sure non-empty directories begin and end in ':'
+ $directory .= ':' unless (substr($directory,-1) eq ':');
+ $directory = ":$directory" unless (substr($directory,0,1) eq ':');
+ } else {
+ $directory = '';
+ }
+ $file = '' unless defined($file);
+
+ return ($volume,$directory,$file);
+}
+
+
+=item splitdir
+
+The opposite of C<catdir()>.
+
+ @dirs = File::Spec->splitdir( $directories );
+
+$directories should 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. Consider using C<splitpath()> otherwise.
+
+Unlike just splitting the directories on the separator, empty directory names
+(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
+colon to distinguish a directory path from a file path, a single trailing colon
+will be ignored, i.e. there's no empty directory name after it.
+
+Hence, on Mac OS, both
+
+ File::Spec->splitdir( ":a:b::c:" ); and
+ File::Spec->splitdir( ":a:b::c" );
+
+yield:
+
+ ( "a", "b", "::", "c")
+
+while
+
+ File::Spec->splitdir( ":a:b::c::" );
+
+yields:
+
+ ( "a", "b", "::", "c", "::")
+
+
+=cut
+
+sub splitdir {
+ my ($self, $path) = @_;
+ my @result = ();
+ my ($head, $sep, $tail, $volume, $directories);
+
+ return @result if ( (!defined($path)) || ($path eq '') );
+ return (':') if ($path eq ':');
+
+ ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
+
+ # deprecated, but handle it correctly
+ if ($volume) {
+ push (@result, $volume);
+ $sep .= ':';
+ }
+
+ while ($sep || $directories) {
+ if (length($sep) > 1) {
+ my $updir_count = length($sep) - 1;
+ for (my $i=0; $i<$updir_count; $i++) {
+ # push '::' updir_count times;
+ # simulate Unix '..' updirs
+ push (@result, '::');
+ }
+ }
+ $sep = '';
+ if ($directories) {
+ ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
+ push (@result, $head);
+ $directories = $tail;
+ }
+ }
+ return @result;
+}
+
+
+=item catpath
+
+ $path = File::Spec->catpath($volume,$directory,$file);
+
+Takes volume, directory and file portions and returns an entire path. On Mac OS,
+$volume, $directory and $file are concatenated. A ':' is inserted if need be. You
+may pass an empty string for each portion. If all portions are empty, the empty
+string is returned. If $volume is empty, the result will be a relative path,
+beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
+is removed form $file and the remainder is returned. If $file is empty, the
+resulting path will have a trailing ':'.
+
+
+=cut
+
+sub catpath {
+ my ($self,$volume,$directory,$file) = @_;
+
+ if ( (! $volume) && (! $directory) ) {
+ $file =~ s/^:// if $file;
+ return $file ;
+ }
+
+ # We look for a volume in $volume, then in $directory, but not both
+
+ my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
+
+ $volume = $dir_volume unless length $volume;
+ my $path = $volume; # may be ''
+ $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
+
+ if ($directory) {
+ $directory = $dir_dirs if $volume;
+ $directory =~ s/^://; # remove leading ':' if any
+ $path .= $directory;
+ $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
+ }
+
+ if ($file) {
+ $file =~ s/^://; # remove leading ':' if any
+ $path .= $file;
+ }
+
+ return $path;
+}
+
+=item abs2rel
+
+Takes a destination path and an optional base path and 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 ) ;
+
+Note that both paths are assumed to have a notation that distinguishes a
+directory path (with trailing ':') from a file path (without trailing ':').
+
+If $base is not present or '', then the current working directory is used.
+If $base is relative, then it is converted to absolute form using C<rel2abs()>.
+This means that it is taken to be relative to the current working directory.
+
+If $path and $base appear to be on two different volumes, we will not
+attempt to resolve the two paths, and we will instead simply return
+$path. Note that previous versions of this module ignored the volume
+of $base, which resulted in garbage results part of the time.
+
+If $base doesn't have a trailing colon, the last element of $base is
+assumed to be a filename. This filename is ignored. Otherwise all path
+components are assumed to be directories.
+
+If $path is relative, it is converted to absolute form using C<rel2abs()>.
+This means that it is taken to be relative to the current working directory.
+
+Based on code written by Shigio Yamaguchi.
+
+
+=cut
+
+# maybe this should be done in canonpath() ?
+sub _resolve_updirs {
+ my $path = shift @_;
+ my $proceed;
+
+ # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
+ do {
+ $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
+ } while ($proceed);
+
+ return $path;
+}
+
+
+sub abs2rel {
+ my($self,$path,$base) = @_;
+
+ # Clean up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ $path = $self->rel2abs( $path ) ;
+ }
+
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ $base = _resolve_updirs( $base ); # resolve updirs in $base
+ }
+ else {
+ $base = _resolve_updirs( $base );
+ }
+
+ # Split up paths - ignore $base's file
+ my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
+ my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
+
+ return $path unless lc( $path_vol ) eq lc( $base_vol );
+
+ # Now, remove all leading components that are the same
+ my @pathchunks = $self->splitdir( $path_dirs );
+ my @basechunks = $self->splitdir( $base_dirs );
+
+ while ( @pathchunks &&
+ @basechunks &&
+ lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+
+ # @pathchunks now has the directories to descend in to.
+ # ensure relative path, even if @pathchunks is empty
+ $path_dirs = $self->catdir( ':', @pathchunks );
+
+ # @basechunks now contains the number of directories to climb out of.
+ $base_dirs = (':' x @basechunks) . ':' ;
+
+ return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
+}
+
+=item rel2abs
+
+Converts a relative path to an absolute path:
+
+ $abs_path = File::Spec->rel2abs( $path ) ;
+ $abs_path = File::Spec->rel2abs( $path, $base ) ;
+
+Note that both paths are assumed to have a notation that distinguishes a
+directory path (with trailing ':') from a file path (without trailing ':').
+
+If $base is not present or '', then $base is set to the current working
+directory. If $base is relative, then it is converted to absolute form
+using C<rel2abs()>. This means that it is taken to be relative to the
+current working directory.
+
+If $base doesn't have a trailing colon, the last element of $base is
+assumed to be a filename. This filename is ignored. Otherwise all path
+components are assumed to be directories.
+
+If $path is already absolute, it is returned and $base is ignored.
+
+Based on code written by Shigio Yamaguchi.
+
+=cut
+
+sub rel2abs {
+ my ($self,$path,$base) = @_;
+
+ if ( ! $self->file_name_is_absolute($path) ) {
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ }
+ elsif ( ! $self->file_name_is_absolute($base) ) {
+ $base = $self->rel2abs($base) ;
+ }
+
+ # Split up paths
+
+ # igonore $path's volume
+ my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
+
+ # ignore $base's file part
+ my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
+
+ # Glom them together
+ $path_dirs = ':' if ($path_dirs eq '');
+ $base_dirs =~ s/:$//; # remove trailing ':', if any
+ $base_dirs = $base_dirs . $path_dirs;
+
+ $path = $self->catpath( $base_vol, $base_dirs, $path_file );
+ }
+ return $path;
+}
+
+
+=back
+
+=head1 AUTHORS
+
+See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
+<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
+
+=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.
+
+=head1 SEE ALSO
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm
new file mode 100644
index 00000000000..a8fa63e3c16
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm
@@ -0,0 +1,274 @@
+package File::Spec::OS2;
+
+use strict;
+use vars qw(@ISA $VERSION);
+require File::Spec::Unix;
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+@ISA = qw(File::Spec::Unix);
+
+sub devnull {
+ return "/dev/nul";
+}
+
+sub case_tolerant {
+ return 1;
+}
+
+sub file_name_is_absolute {
+ my ($self,$file) = @_;
+ return scalar($file =~ m{^([a-z]:)?[\\/]}is);
+}
+
+sub path {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:g;
+ my @path = split(';',$path);
+ foreach (@path) { $_ = '.' if $_ eq '' }
+ return @path;
+}
+
+sub _cwd {
+ # In OS/2 the "require Cwd" is unnecessary bloat.
+ return Cwd::sys_cwd();
+}
+
+my $tmpdir;
+sub tmpdir {
+ return $tmpdir if defined $tmpdir;
+ my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy
+ $tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/' );
+}
+
+sub catdir {
+ my $self = shift;
+ my @args = @_;
+ foreach (@args) {
+ tr[\\][/];
+ # append a backslash to each argument unless it has one there
+ $_ .= "/" unless m{/$};
+ }
+ return $self->canonpath(join('', @args));
+}
+
+sub canonpath {
+ my ($self,$path) = @_;
+ return unless defined $path;
+
+ $path =~ s/^([a-z]:)/\l$1/s;
+ $path =~ s|\\|/|g;
+ $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
+ $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
+ $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
+ $path =~ s|/\Z(?!\n)||
+ unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
+ $path =~ s{^/\.\.$}{/}; # /.. -> /
+ 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
+ return $path;
+}
+
+
+sub splitpath {
+ my ($self,$path, $nofile) = @_;
+ my ($volume,$directory,$file) = ('','','');
+ if ( $nofile ) {
+ $path =~
+ m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
+ (.*)
+ }xs;
+ $volume = $1;
+ $directory = $2;
+ }
+ else {
+ $path =~
+ m{^ ( (?: [a-zA-Z]: |
+ (?:\\\\|//)[^\\/]+[\\/][^\\/]+
+ )?
+ )
+ ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
+ (.*)
+ }xs;
+ $volume = $1;
+ $directory = $2;
+ $file = $3;
+ }
+
+ return ($volume,$directory,$file);
+}
+
+
+sub splitdir {
+ my ($self,$directories) = @_ ;
+ split m|[\\/]|, $directories, -1;
+}
+
+
+sub catpath {
+ my ($self,$volume,$directory,$file) = @_;
+
+ # If it's UNC, make sure the glue separator is there, reusing
+ # whatever separator is first in the $volume
+ $volume .= $1
+ if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
+ $directory =~ m@^[^\\/]@s
+ ) ;
+
+ $volume .= $directory ;
+
+ # If the volume is not just A:, make sure the glue separator is
+ # there, reusing whatever separator is first in the $volume if possible.
+ if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
+ $volume =~ m@[^\\/]\Z(?!\n)@ &&
+ $file =~ m@[^\\/]@
+ ) {
+ $volume =~ m@([\\/])@ ;
+ my $sep = $1 ? $1 : '/' ;
+ $volume .= $sep ;
+ }
+
+ $volume .= $file ;
+
+ return $volume ;
+}
+
+
+sub abs2rel {
+ my($self,$path,$base) = @_;
+
+ # Clean up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ $path = $self->rel2abs( $path ) ;
+ } else {
+ $path = $self->canonpath( $path ) ;
+ }
+
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ } elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ } else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ # Split up paths
+ my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
+ my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
+ return $path unless $path_volume eq $base_volume;
+
+ # Now, remove all leading components that are the same
+ my @pathchunks = $self->splitdir( $path_directories );
+ my @basechunks = $self->splitdir( $base_directories );
+
+ while ( @pathchunks &&
+ @basechunks &&
+ lc( $pathchunks[0] ) eq lc( $basechunks[0] )
+ ) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+
+ # No need to catdir, we know these are well formed.
+ $path_directories = CORE::join( '/', @pathchunks );
+ $base_directories = CORE::join( '/', @basechunks );
+
+ # $base_directories now contains the directories the resulting relative
+ # path must ascend out of before it can descend to $path_directory. So,
+ # replace all names with $parentDir
+
+ #FA Need to replace between backslashes...
+ $base_directories =~ s|[^\\/]+|..|g ;
+
+ # Glue the two together, using a separator if necessary, and preventing an
+ # empty result.
+
+ #FA Must check that new directories are not empty.
+ if ( $path_directories ne '' && $base_directories ne '' ) {
+ $path_directories = "$base_directories/$path_directories" ;
+ } else {
+ $path_directories = "$base_directories$path_directories" ;
+ }
+
+ return $self->canonpath(
+ $self->catpath( "", $path_directories, $path_file )
+ ) ;
+}
+
+
+sub rel2abs {
+ my ($self,$path,$base ) = @_;
+
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ my ( $path_directories, $path_file ) =
+ ($self->splitpath( $path, 1 ))[1,2] ;
+
+ my ( $base_volume, $base_directories ) =
+ $self->splitpath( $base, 1 ) ;
+
+ $path = $self->catpath(
+ $base_volume,
+ $self->catdir( $base_directories, $path_directories ),
+ $path_file
+ ) ;
+ }
+
+ return $self->canonpath( $path ) ;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Spec::OS2 - methods for OS/2 file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::OS2; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+Amongst the changes made for OS/2 are...
+
+=over 4
+
+=item tmpdir
+
+Modifies the list of places temp directory information is looked for.
+
+ $ENV{TMPDIR}
+ $ENV{TEMP}
+ $ENV{TMP}
+ /tmp
+ /
+
+=item splitpath
+
+Volumes can be drive letters or UNC sharenames (\\server\share).
+
+=back
+
+=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
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm
new file mode 100644
index 00000000000..8fd2320a392
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm
@@ -0,0 +1,521 @@
+package File::Spec::Unix;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+=head1 NAME
+
+File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
+
+=head1 SYNOPSIS
+
+ require File::Spec::Unix; # Done automatically by File::Spec
+
+=head1 DESCRIPTION
+
+Methods for manipulating file specifications. Other File::Spec
+modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
+override specific methods.
+
+=head1 METHODS
+
+=over 2
+
+=item canonpath()
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminates successive slashes and successive "/.".
+
+ $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.
+
+=cut
+
+sub canonpath {
+ my ($self,$path) = @_;
+ return unless defined $path;
+
+ # Handle POSIX-style node names beginning with double slash (qnx, nto)
+ # (POSIX says: "a pathname that begins with two successive slashes
+ # may be interpreted in an implementation-defined manner, although
+ # more than two leading slashes shall be treated as a single slash.")
+ my $node = '';
+ my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
+
+
+ if ( $double_slashes_special
+ && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
+ $node = $1;
+ }
+ # This used to be
+ # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
+ # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
+ # (Mainly because trailing "" directories didn't get stripped).
+ # Why would cygwin avoid collapsing multiple slashes into one? --jhi
+ $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
+ $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
+ $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
+ $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
+ $path =~ s|^/\.\.$|/|; # /.. -> /
+ $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
+ return "$node$path";
+}
+
+=item 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
+OS2. Of course, if this is the root directory, don't cut off the
+trailing slash :-)
+
+=cut
+
+sub catdir {
+ my $self = shift;
+
+ $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ my $self = shift;
+ my $file = $self->canonpath(pop @_);
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $dir .= "/" unless substr($dir,-1) eq "/";
+ return $dir.$file;
+}
+
+=item curdir
+
+Returns a string representation of the current directory. "." on UNIX.
+
+=cut
+
+sub curdir { '.' }
+
+=item devnull
+
+Returns a string representation of the null device. "/dev/null" on UNIX.
+
+=cut
+
+sub devnull { '/dev/null' }
+
+=item rootdir
+
+Returns a string representation of the root directory. "/" on UNIX.
+
+=cut
+
+sub rootdir { '/' }
+
+=item tmpdir
+
+Returns a string representation of the first writable directory from
+the following list or the current directory if none from the list are
+writable:
+
+ $ENV{TMPDIR}
+ /tmp
+
+Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
+is tainted, it is not used.
+
+=cut
+
+my $tmpdir;
+sub _tmpdir {
+ return $tmpdir if defined $tmpdir;
+ my $self = shift;
+ my @dirlist = @_;
+ {
+ no strict 'refs';
+ if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
+ require Scalar::Util;
+ @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
+ }
+ }
+ foreach (@dirlist) {
+ next unless defined && -d && -w _;
+ $tmpdir = $_;
+ last;
+ }
+ $tmpdir = $self->curdir unless defined $tmpdir;
+ $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
+ return $tmpdir;
+}
+
+sub tmpdir {
+ return $tmpdir if defined $tmpdir;
+ $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
+}
+
+=item updir
+
+Returns a string representation of the parent directory. ".." on UNIX.
+
+=cut
+
+sub 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.)
+
+=cut
+
+sub no_upwards {
+ my $self = shift;
+ return grep(!/^\.{1,2}\z/s, @_);
+}
+
+=item case_tolerant
+
+Returns a true or false value indicating, respectively, that alphabetic
+is not or is significant when comparing file specifications.
+
+=cut
+
+sub case_tolerant { 0 }
+
+=item file_name_is_absolute
+
+Takes as argument a path and returns true if it is an 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>).
+
+=cut
+
+sub file_name_is_absolute {
+ my ($self,$file) = @_;
+ return scalar($file =~ m:^/:s);
+}
+
+=item path
+
+Takes no argument, returns the environment variable PATH as an array.
+
+=cut
+
+sub path {
+ return () unless exists $ENV{PATH};
+ my @path = split(':', $ENV{PATH});
+ foreach (@path) { $_ = '.' if $_ eq '' }
+ return @path;
+}
+
+=item join
+
+join is the same as catfile.
+
+=cut
+
+sub join {
+ my $self = shift;
+ return $self->catfile(@_);
+}
+
+=item splitpath
+
+ ($volume,$directories,$file) = File::Spec->splitpath( $path );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path into volume, directory, and filename portions. On systems
+with no concept of volume, returns '' for volume.
+
+For systems with no syntax differentiating filenames from directories,
+assumes that the last file is a path unless $no_file is true or a
+trailing separator or /. or /.. is present. On Unix this means that $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.
+
+=cut
+
+sub splitpath {
+ my ($self,$path, $nofile) = @_;
+
+ my ($volume,$directory,$file) = ('','','');
+
+ if ( $nofile ) {
+ $directory = $path;
+ }
+ else {
+ $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
+ $directory = $1;
+ $file = $2;
+ }
+
+ return ($volume,$directory,$file);
+}
+
+
+=item splitdir
+
+The opposite of L</catdir()>.
+
+ @dirs = File::Spec->splitdir( $directories );
+
+$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 OSs.
+
+On Unix,
+
+ File::Spec->splitdir( "/a/b//c/" );
+
+Yields:
+
+ ( '', 'a', 'b', '', 'c', '' )
+
+=cut
+
+sub splitdir {
+ return split m|/|, $_[1], -1; # Preserve trailing fields
+}
+
+
+=item catpath()
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, $volume is ignored, and directory and file are concatenated. A '/' is
+inserted if needed (though if the directory portion doesn't start with
+'/' it is not added). On other OSs, $volume is significant.
+
+=cut
+
+sub catpath {
+ my ($self,$volume,$directory,$file) = @_;
+
+ if ( $directory ne '' &&
+ $file ne '' &&
+ substr( $directory, -1 ) ne '/' &&
+ substr( $file, 0, 1 ) ne '/'
+ ) {
+ $directory .= "/$file" ;
+ }
+ else {
+ $directory .= $file ;
+ }
+
+ return $directory ;
+}
+
+=item abs2rel
+
+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 $base is not present or '', then L<cwd()|Cwd> is used. If $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>.
+
+On systems that have a grammar that indicates filenames, this ignores the
+$base filename. Otherwise all path components are assumed to be
+directories.
+
+If $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>.
+
+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.
+
+=cut
+
+sub abs2rel {
+ my($self,$path,$base) = @_;
+ $base = $self->_cwd() unless defined $base and length $base;
+
+ ($path, $base) = map $self->canonpath($_), $path, $base;
+
+ if (grep $self->file_name_is_absolute($_), $path, $base) {
+ ($path, $base) = map $self->rel2abs($_), $path, $base;
+ }
+ else {
+ # save a couple of cwd()s if both paths are relative
+ ($path, $base) = map $self->catdir('/', $_), $path, $base;
+ }
+
+ my ($path_volume) = $self->splitpath($path, 1);
+ my ($base_volume) = $self->splitpath($base, 1);
+
+ # Can't relativize across volumes
+ return $path unless $path_volume eq $base_volume;
+
+ my $path_directories = ($self->splitpath($path, 1))[1];
+ my $base_directories = ($self->splitpath($base, 1))[1];
+
+ # For UNC paths, the user might give a volume like //foo/bar that
+ # strictly speaking has no directory portion. Treat it as if it
+ # had the root directory for that volume.
+ if (!length($base_directories) and $self->file_name_is_absolute($base)) {
+ $base_directories = $self->rootdir;
+ }
+
+ # Now, remove all leading components that are the same
+ my @pathchunks = $self->splitdir( $path_directories );
+ my @basechunks = $self->splitdir( $base_directories );
+
+ if ($base_directories eq $self->rootdir) {
+ shift @pathchunks;
+ return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
+ }
+
+ while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+ return $self->curdir unless @pathchunks || @basechunks;
+
+ # $base now contains the directories the resulting relative path
+ # must ascend out of before it can descend to $path_directory.
+ my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
+ return $self->canonpath( $self->catpath('', $result_dirs, '') );
+}
+
+sub _same {
+ $_[1] eq $_[2];
+}
+
+=item rel2abs()
+
+Converts a relative path to an absolute path.
+
+ $abs_path = File::Spec->rel2abs( $path ) ;
+ $abs_path = File::Spec->rel2abs( $path, $base ) ;
+
+If $base is not present or '', then L<cwd()|Cwd> is used. If $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>.
+
+On systems that have a grammar that indicates filenames, this ignores
+the $base filename. Otherwise all path components are assumed to be
+directories.
+
+If $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.
+
+=cut
+
+sub rel2abs {
+ my ($self,$path,$base ) = @_;
+
+ # Clean up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd();
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ # Glom them together
+ $path = $self->catdir( $base, $path ) ;
+ }
+
+ return $self->canonpath( $path ) ;
+}
+
+=back
+
+=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.
+
+=head1 SEE ALSO
+
+L<File::Spec>
+
+=cut
+
+# Internal routine to File::Spec, no point in making this public since
+# it is the standard Cwd interface. Most of the platform-specific
+# File::Spec subclasses use this.
+sub _cwd {
+ require Cwd;
+ Cwd::getcwd();
+}
+
+
+# Internal method to reduce xx\..\yy -> yy
+sub _collapse {
+ my($fs, $path) = @_;
+
+ my $updir = $fs->updir;
+ my $curdir = $fs->curdir;
+
+ my($vol, $dirs, $file) = $fs->splitpath($path);
+ my @dirs = $fs->splitdir($dirs);
+ pop @dirs if @dirs && $dirs[-1] eq '';
+
+ my @collapsed;
+ foreach my $dir (@dirs) {
+ if( $dir eq $updir and # if we have an updir
+ @collapsed and # and something to collapse
+ length $collapsed[-1] and # and its not the rootdir
+ $collapsed[-1] ne $updir and # nor another updir
+ $collapsed[-1] ne $curdir # nor the curdir
+ )
+ { # then
+ pop @collapsed; # collapse
+ }
+ else { # else
+ push @collapsed, $dir; # just hang onto it
+ }
+ }
+
+ return $fs->catpath($vol,
+ $fs->catdir(@collapsed),
+ $file
+ );
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
new file mode 100644
index 00000000000..6135fc54635
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
@@ -0,0 +1,1141 @@
+package File::Spec::VMS;
+
+use strict;
+use vars qw(@ISA $VERSION);
+require File::Spec::Unix;
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+@ISA = qw(File::Spec::Unix);
+
+use File::Basename;
+use VMS::Filespec;
+
+=head1 NAME
+
+File::Spec::VMS - methods for VMS file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::VMS; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+The default behavior is to allow either VMS or Unix syntax on input and to
+return VMS syntax on output, even when Unix syntax was given on input.
+
+When used with a Perl of version 5.10 or greater and a CRTL possessing the
+relevant capabilities, override behavior depends on the CRTL features
+C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>. When the
+C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
+in Unix syntax, the output will be in Unix syntax. If
+C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
+determined from the input syntax, the output will be in Unix syntax.
+
+=over 4
+
+=cut
+
+# Need to look up the feature settings. The preferred way is to use the
+# VMS::Feature module, but that may not be available to dual life modules.
+
+my $use_feature;
+BEGIN {
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $use_feature = 1;
+ }
+}
+
+# Need to look up the UNIX report mode. This may become a dynamic mode
+# in the future.
+sub _unix_rpt {
+ my $unix_rpt;
+ if ($use_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 _efs {
+ my $efs;
+ if ($use_feature) {
+ $efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
+ $efs = $env_efs =~ /^[ET1]/i;
+ }
+ return $efs;
+}
+
+=item canonpath (override)
+
+Removes redundant portions of file specifications according to the syntax
+detected.
+
+=cut
+
+
+sub canonpath {
+ my($self,$path) = @_;
+
+ return undef unless defined $path;
+
+ my $efs = $self->_efs;
+
+ if ($path =~ m|/|) { # Fake Unix
+ my $pathify = $path =~ m|/\Z(?!\n)|;
+ $path = $self->SUPER::canonpath($path);
+
+ # Do not convert to VMS when EFS character sets are in use
+ return $path if $efs;
+
+ if ($pathify) { return vmspath($path); }
+ else { return vmsify($path); }
+ }
+ else {
+
+#FIXME - efs parsing has different rules. Characters in a VMS filespec
+# are only delimiters if not preceded by '^';
+
+ $path =~ tr/<>/[]/; # < and > ==> [ and ]
+ $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
+ $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
+ $path =~ s/\[000000\./\[/g; # [000000. ==> [
+ $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
+ $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
+ 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
+ # That loop does the following
+ # with any amount of dashes:
+ # .-.-. ==> .--.
+ # [-.-. ==> [--.
+ # .-.-] ==> .--]
+ # [-.-] ==> [--]
+ 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
+ # That loop does the following
+ # with any amount (minimum 2)
+ # of dashes:
+ # .foo.--. ==> .-.
+ # .foo.--] ==> .-]
+ # [foo.--. ==> [-.
+ # [foo.--] ==> [-]
+ #
+ # And then, the remaining cases
+ $path =~ s/\[\.-/[-/; # [.- ==> [-
+ $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
+ $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
+ $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
+ $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
+ $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
+ return $path;
+ }
+}
+
+=item catdir (override)
+
+Concatenates a list of file specifications, and returns the result as a
+directory specification. No check is made for "impossible"
+cases (e.g. elements other than the first being absolute filespecs).
+
+=cut
+
+sub catdir {
+ my $self = shift;
+ my $dir = pop;
+
+ my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
+
+
+ my @dirs = grep {defined() && length()} @_;
+ if ($efs) {
+ # Legacy mode removes blank entries.
+ # But that breaks existing generic perl code that
+ # uses a blank path at the beginning of the array
+ # to indicate an absolute path.
+ # So put it back if found.
+ if (@_) {
+ if ($_[0] eq '') {
+ unshift @dirs, '';
+ }
+ }
+ }
+
+ my $rslt;
+ if (@dirs) {
+ my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
+ my ($spath,$sdir) = ($path,$dir);
+
+ if ($efs) {
+ # Extended character set in use, go into DWIM mode.
+
+ # Now we need to identify what the directory is in
+ # of the specification in order to merge them.
+ my $path_unix = 0;
+ $path_unix = 1 if ($path =~ m#/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ my $path_vms = 0;
+ $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+ my $dir_unix = 0;
+ $dir_unix = 1 if ($dir =~ m#/#);
+ $dir_unix = 1 if ($dir =~ /^\.\.?$/);
+ my $dir_vms = 0;
+ $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
+ $dir_vms = 1 if ($dir =~ /^--?$/);
+
+ my $unix_mode = 0;
+ if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
+ # Ambiguous, so if in $unix_rpt mode then assume UNIX.
+ $unix_mode = 1 if $unix_rpt;
+ } else {
+ $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
+ $unix_mode = 1 if ($path_unix || $dir_unix);
+ }
+
+ if ($unix_mode) {
+
+ # Fix up mixed syntax imput as good as possible - GIGO
+ $path = unixify($path) if $path_vms;
+ $dir = unixify($dir) if $dir_vms;
+
+ $rslt = $path;
+ # Append a path delimiter
+ $rslt .= '/' unless ($rslt =~ m#/$#);
+
+ $rslt .= $dir;
+ return $self->SUPER::canonpath($rslt);
+ } else {
+
+ #with <> posible instead of [.
+ # Normalize the brackets
+ # Fixme - need to not switch when preceded by ^.
+ $path =~ s/</\[/g;
+ $path =~ s/>/\]/g;
+ $dir =~ s/</\[/g;
+ $dir =~ s/>/\]/g;
+
+ # Fix up mixed syntax imput as good as possible - GIGO
+ $path = vmsify($path) if $path_unix;
+ $dir = vmsify($dir) if $dir_unix;
+
+ #Possible path values: foo: [.foo] [foo] foo, and $(foo)
+ #or starting with '-', or foo.dir
+ #If path is foo, it needs to be converted to [.foo]
+
+ # Fix up a bare path name.
+ unless ($path_vms) {
+ $path =~ s/\.dir\Z(?!\n)//i;
+ if (($path ne '') && ($path !~ /^-/)) {
+ # Non blank and not prefixed with '-', add a dot
+ $path = '[.' . $path;
+ } else {
+ # Just start a directory.
+ $path = '[' . $path;
+ }
+ } else {
+ $path =~ s/\]$//;
+ }
+
+ #Possible dir values: [.dir] dir and $(foo)
+
+ # No punctuation may have a trailing .dir
+ unless ($dir_vms) {
+ $dir =~ s/\.dir\Z(?!\n)//i;
+ } else {
+
+ #strip off the brackets
+ $dir =~ s/^\[//;
+ $dir =~ s/\]$//;
+ }
+
+ #strip off the leading dot if present.
+ $dir =~ s/^\.//;
+
+ # Now put the specifications together.
+ if ($dir ne '') {
+ # Add a separator unless this is an absolute path
+ $path .= '.' if ($path ne '[');
+ $rslt = $path . $dir . ']';
+ } else {
+ $rslt = $path . ']';
+ }
+ }
+
+ } else {
+ # Traditional ODS-2 mode.
+ $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
+
+ $sdir = $self->eliminate_macros($sdir)
+ unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
+ $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",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 ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
+ }
+ } else {
+ # Single directory, just make sure it is in directory format
+ # Return an empty string on null input, and pass through macros.
+
+ if (not defined $dir or not length $dir) { $rslt = ''; }
+ elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
+ $rslt = $dir;
+ } else {
+ my $unix_mode = 0;
+
+ if ($efs) {
+ my $dir_unix = 0;
+ $dir_unix = 1 if ($dir =~ m#/#);
+ $dir_unix = 1 if ($dir =~ /^\.\.?$/);
+ my $dir_vms = 0;
+ $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
+ $dir_vms = 1 if ($dir =~ /^--?$/);
+
+ if ($dir_vms == $dir_unix) {
+ # Ambiguous, so if in $unix_rpt mode then assume UNIX.
+ $unix_mode = 1 if $unix_rpt;
+ } else {
+ $unix_mode = 1 if $dir_unix;
+ }
+ }
+
+ if ($unix_mode) {
+ return $dir;
+ } else {
+ # For VMS, force it to be in directory format
+ $rslt = vmspath($dir);
+ }
+ }
+ }
+ return $self->canonpath($rslt);
+}
+
+=item catfile (override)
+
+Concatenates a list of directory specifications with a filename specification
+to build a path.
+
+=cut
+
+sub catfile {
+ my $self = shift;
+ my $tfile = pop();
+ my $file = $self->canonpath($tfile);
+ my @files = grep {defined() && length()} @_;
+
+ my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
+
+ # Assume VMS mode
+ my $unix_mode = 0;
+ my $file_unix = 0;
+ my $file_vms = 0;
+ if ($efs) {
+
+ # Now we need to identify format the file is in
+ # of the specification in order to merge them.
+ $file_unix = 1 if ($tfile =~ m#/#);
+ $file_unix = 1 if ($tfile =~ /^\.\.?$/);
+ $file_vms = 1 if ($tfile =~ m#(?<!\^)[\[<\]:]#);
+ $file_vms = 1 if ($tfile =~ /^--?$/);
+
+ # We may know for sure what the format is.
+ if (($file_unix != $file_vms)) {
+ $unix_mode = 1 if ($file_unix && $unix_rpt);
+ }
+ }
+
+ my $rslt;
+ if (@files) {
+ # concatenate the directories.
+ my $path;
+ if (@files == 1) {
+ $path = $files[0];
+ } else {
+ if ($file_vms) {
+ # We need to make sure this is in VMS mode to avoid doing
+ # both a vmsify and unixfy on the same path, as that may
+ # lose significant data.
+ my $i = @files - 1;
+ my $tdir = $files[$i];
+ my $tdir_vms = 0;
+ my $tdir_unix = 0;
+ $tdir_vms = 1 if ($tdir =~ m#(?<!\^)[\[<\]:]#);
+ $tdir_unix = 1 if ($tdir =~ m#/#);
+ $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
+
+ if (!$tdir_vms) {
+ if ($tdir_unix) {
+ $tdir = vmspath($tdir);
+ } else {
+ $tdir =~ s/\.dir\Z(?!\n)//i;
+ $tdir = '[.' . $tdir . ']';
+ }
+ $files[$i] = $tdir;
+ }
+ }
+ $path = $self->catdir(@files);
+ }
+ my $spath = $path;
+
+ # Some thing building a VMS path in pieces may try to pass a
+ # directory name in filename format, so normalize it.
+ $spath =~ s/\.dir\Z(?!\n)//i;
+
+ # if the spath ends with a directory delimiter and the file is bare,
+ # then just concat them.
+ if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
+ $rslt = "$spath$file";
+ } else {
+ if ($efs) {
+
+ # Now we need to identify what the directory is in
+ # of the specification in order to merge them.
+ my $spath_unix = 0;
+ $spath_unix = 1 if ($spath =~ m#/#);
+ $spath_unix = 1 if ($spath =~ /^\.\.?$/);
+ my $spath_vms = 0;
+ $spath_vms = 1 if ($spath =~ m#(?<!\^)[\[<\]:]#);
+ $spath_vms = 1 if ($spath =~ /^--?$/);
+
+ # Assume VMS mode
+ if (($spath_unix == $spath_vms) &&
+ ($file_unix == $file_vms)) {
+ # Ambigous, so if in $unix_rpt mode then assume UNIX.
+ $unix_mode = 1 if $unix_rpt;
+ } else {
+ $unix_mode = 1
+ if (($spath_unix || $file_unix) && $unix_rpt);
+ }
+
+ if (!$unix_mode) {
+ if ($spath_vms) {
+ $spath = '[' . $spath . ']' if $spath =~ /^-/;
+ $rslt = vmspath($spath);
+ } else {
+ $rslt = '[.' . $spath . ']';
+ }
+ $file = vmsify($file) if ($file_unix);
+ } else {
+ $spath = unixify($spath) if ($spath_vms);
+ $rslt = $spath;
+ $file = unixify($file) if ($file_vms);
+
+ # Unix merge may need a directory delimitor.
+ # A null path indicates root on Unix.
+ $rslt .= '/' unless ($rslt =~ m#/$#);
+ }
+
+ $rslt .= $file;
+ $rslt =~ s/\]\[//;
+
+ } else {
+ # Traditional VMS Perl mode expects that this is done.
+ # Note for future maintainers:
+ # This is left here for compatibility with perl scripts
+ # that have come to expect this behavior, even though
+ # usually the Perl scripts ported to VMS have to be
+ # patched because of it changing Unix syntax file
+ # to VMS format.
+
+ $rslt = $self->eliminate_macros($spath);
+
+
+ $rslt = vmsify($rslt.((defined $rslt) &&
+ ($rslt ne '') ? '/' : '').unixify($file));
+ }
+ }
+ }
+ else {
+ # Only passed a single file?
+ my $xfile = $file;
+
+ # Traditional VMS perl expects this conversion.
+ $xfile = vmsify($file) unless ($efs);
+
+ $rslt = (defined($file) && length($file)) ? $xfile : '';
+ }
+ return $self->canonpath($rslt) unless $unix_rpt;
+
+ # In Unix report mode, do not strip off redundent path information.
+ return $rslt;
+}
+
+
+=item curdir (override)
+
+Returns a string representation of the current directory: '[]' or '.'
+
+=cut
+
+sub curdir {
+ my $self = shift @_;
+ return '.' if ($self->_unix_rpt);
+ return '[]';
+}
+
+=item devnull (override)
+
+Returns a string representation of the null device: '_NLA0:' or '/dev/null'
+
+=cut
+
+sub devnull {
+ my $self = shift @_;
+ return '/dev/null' if ($self->_unix_rpt);
+ return "_NLA0:";
+}
+
+=item rootdir (override)
+
+Returns a string representation of the root directory: 'SYS$DISK:[000000]'
+or '/'
+
+=cut
+
+sub rootdir {
+ my $self = shift @_;
+ if ($self->_unix_rpt) {
+ # Root may exist, try it first.
+ my $try = '/';
+ my ($dev1, $ino1) = stat('/');
+ my ($dev2, $ino2) = stat('.');
+
+ # Perl falls back to '.' if it can not determine '/'
+ if (($dev1 != $dev2) || ($ino1 != $ino2)) {
+ return $try;
+ }
+ # Fall back to UNIX format sys$disk.
+ return '/sys$disk/';
+ }
+ return 'SYS$DISK:[000000]';
+}
+
+=item tmpdir (override)
+
+Returns a string representation of the first writable directory
+from the following list or '' if none are writable:
+
+ /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
+ sys$scratch:
+ $ENV{TMPDIR}
+
+Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
+is tainted, it is not used.
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+ my $self = shift @_;
+ return $tmpdir if defined $tmpdir;
+ if ($self->_unix_rpt) {
+ $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
+ return $tmpdir;
+ }
+
+ $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
+}
+
+=item updir (override)
+
+Returns a string representation of the parent directory: '[-]' or '..'
+
+=cut
+
+sub updir {
+ my $self = shift @_;
+ return '..' if ($self->_unix_rpt);
+ return '[-]';
+}
+
+=item case_tolerant (override)
+
+VMS file specification syntax is case-tolerant.
+
+=cut
+
+sub case_tolerant {
+ return 1;
+}
+
+=item path (override)
+
+Translate logical name DCL$PATH as a searchlist, rather than trying
+to C<split> string value of C<$ENV{'PATH'}>.
+
+=cut
+
+sub path {
+ my (@dirs,$dir,$i);
+ while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
+ return @dirs;
+}
+
+=item file_name_is_absolute (override)
+
+Checks for VMS directory spec as well as Unix separators.
+
+=cut
+
+sub file_name_is_absolute {
+ my ($self,$file) = @_;
+ # If it's a logical name, expand it.
+ $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
+ return scalar($file =~ m!^/!s ||
+ $file =~ m![<\[][^.\-\]>]! ||
+ $file =~ /:[^<\[]/);
+}
+
+=item splitpath (override)
+
+ ($volume,$directories,$file) = File::Spec->splitpath( $path );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Passing a true value for C<$no_file> indicates that the path being
+split only contains directory components, even on systems where you
+can usually (when not supporting a foreign syntax) tell the difference
+between directories and files at a glance.
+
+=cut
+
+sub splitpath {
+ my($self,$path, $nofile) = @_;
+ my($dev,$dir,$file) = ('','','');
+ my $efs = $self->_efs;
+ my $vmsify_path = vmsify($path);
+ if ($efs) {
+ my $path_vms = 0;
+ $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+ if (!$path_vms) {
+ return $self->SUPER::splitpath($path, $nofile);
+ }
+ $vmsify_path = $path;
+ }
+
+ if ( $nofile ) {
+ #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
+ #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
+ if( $vmsify_path =~ /(.*)\](.+)/ ){
+ $vmsify_path = $1.'.'.$2.']';
+ }
+ $vmsify_path =~ /(.+:)?(.*)/s;
+ $dir = defined $2 ? $2 : ''; # dir can be '0'
+ return ($1 || '',$dir,$file);
+ }
+ else {
+ $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
+ return ($1 || '',$2 || '',$3);
+ }
+}
+
+=item splitdir (override)
+
+Split a directory specification into the components.
+
+=cut
+
+sub splitdir {
+ my($self,$dirspec) = @_;
+ my @dirs = ();
+ return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
+
+ my $efs = $self->_efs;
+
+ my $dir_unix = 0;
+ $dir_unix = 1 if ($dirspec =~ m#/#);
+ $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
+
+ # Unix filespecs in EFS mode handled by Unix routines.
+ if ($efs && $dir_unix) {
+ return $self->SUPER::splitdir($dirspec);
+ }
+
+ # FIX ME, only split for VMS delimiters not prefixed with '^'.
+
+ $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
+ $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
+ $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
+ $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
+ $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
+ $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
+ while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
+ # That loop does the following
+ # with any amount of dashes:
+ # .--. ==> .-.-.
+ # [--. ==> [-.-.
+ # .--] ==> .-.-]
+ # [--] ==> [-.-]
+ $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
+ $dirspec =~ s/^(\[|<)\./$1/;
+ @dirs = split /(?<!\^)\./, vmspath($dirspec);
+ $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
+ @dirs;
+}
+
+
+=item catpath (override)
+
+Construct a complete filespec.
+
+=cut
+
+sub catpath {
+ my($self,$dev,$dir,$file) = @_;
+
+ my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
+
+ my $unix_mode = 0;
+ my $dir_unix = 0;
+ $dir_unix = 1 if ($dir =~ m#/#);
+ $dir_unix = 1 if ($dir =~ /^\.\.?$/);
+ my $dir_vms = 0;
+ $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
+ $dir_vms = 1 if ($dir =~ /^--?$/);
+
+ if ($efs && (length($dev) == 0)) {
+ if ($dir_unix == $dir_vms) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $dir_unix;
+ }
+ }
+
+ # We look for a volume in $dev, then in $dir, but not both
+ # but only if using VMS syntax.
+ if (!$unix_mode) {
+ $dir = vmspath($dir) if $dir_unix;
+ my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
+ $dev = $dir_volume unless length $dev;
+ $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
+ $dir_dir;
+ }
+ if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
+ else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
+ if (length($dev) or length($dir)) {
+ if ($efs) {
+ if ($unix_mode) {
+ $dir .= '/' unless ($dir =~ m#/$#);
+ } else {
+ $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
+ $dir = "[$dir]" unless $dir =~ /^[\[<]/;
+ }
+ } else {
+ $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
+ $dir = vmspath($dir);
+ }
+ }
+ $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
+ "$dev$dir$file";
+}
+
+=item abs2rel (override)
+
+Attempt to convert a file specification to a relative specification.
+On a system with volumes, like VMS, this may not be possible.
+
+=cut
+
+sub abs2rel {
+ my $self = shift;
+ my($path,$base) = @_;
+
+ my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
+
+ # We need to identify what the directory is in
+ # of the specification in order to process them
+ my $path_unix = 0;
+ $path_unix = 1 if ($path =~ m#/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ my $path_vms = 0;
+ $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+
+ my $unix_mode = 0;
+ if ($path_vms == $path_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $path_unix;
+ }
+
+ my $base_unix = 0;
+ my $base_vms = 0;
+
+ if (defined $base) {
+ $base_unix = 1 if ($base =~ m#/#);
+ $base_unix = 1 if ($base =~ /^\.\.?$/);
+ $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
+ $base_vms = 1 if ($base =~ /^--?$/);
+
+ if ($path_vms == $path_unix) {
+ if ($base_vms == $base_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $base_unix;
+ }
+ } else {
+ $unix_mode = 0 if $base_vms;
+ }
+ }
+
+ if ($efs) {
+ if ($unix_mode) {
+ # We are UNIX mode.
+ $base = unixpath($base) if $base_vms;
+ $base = unixify($path) if $path_vms;
+
+ # Here VMS is different, and in order to do this right
+ # we have to take the realpath for both the path and the base
+ # so that we can remove the common components.
+
+ if ($path =~ m#^/#) {
+ if (defined $base) {
+
+ # For the shorterm, if the starting directories are
+ # common, remove them.
+ my $bq = qq($base);
+ $bq =~ s/\$/\\\$/;
+ $path =~ s/^$bq//i;
+ }
+ return $path;
+ }
+
+ return File::Spec::Unix::abs2rel( $self, $path, $base );
+
+ } else {
+ $base = vmspath($base) if $base_unix;
+ $path = vmsify($path) if $path_unix;
+ }
+ }
+
+ unless (defined $base and length $base) {
+ $base = $self->_cwd();
+ if ($efs) {
+ $base_unix = 1 if ($base =~ m#/#);
+ $base_unix = 1 if ($base =~ /^\.\.?$/);
+ $base = vmspath($base) if $base_unix;
+ }
+ }
+
+ for ($path, $base) { $_ = $self->canonpath($_) }
+
+ # Are we even starting $path on the same (node::)device as $base? Note that
+ # logical paths or nodename differences may be on the "same device"
+ # but the comparison that ignores device differences so as to concatenate
+ # [---] up directory specs is not even a good idea in cases where there is
+ # a logical path difference between $path and $base nodename and/or device.
+ # Hence we fall back to returning the absolute $path spec
+ # if there is a case blind device (or node) difference of any sort
+ # and we do not even try to call $parse() or consult %ENV for $trnlnm()
+ # (this module needs to run on non VMS platforms after all).
+
+ my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
+ my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
+ return $path unless lc($path_volume) eq lc($base_volume);
+
+ for ($path, $base) { $_ = $self->rel2abs($_) }
+
+ # Now, remove all leading components that are the same
+ my @pathchunks = $self->splitdir( $path_directories );
+ my $pathchunks = @pathchunks;
+ unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
+ my @basechunks = $self->splitdir( $base_directories );
+ my $basechunks = @basechunks;
+ unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
+
+ while ( @pathchunks &&
+ @basechunks &&
+ lc( $pathchunks[0] ) eq lc( $basechunks[0] )
+ ) {
+ shift @pathchunks ;
+ shift @basechunks ;
+ }
+
+ # @basechunks now contains the directories to climb out of,
+ # @pathchunks now has the directories to descend in to.
+ if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
+ $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
+ }
+ else {
+ $path_directories = join '.', @pathchunks;
+ }
+ $path_directories = '['.$path_directories.']';
+ return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
+}
+
+
+=item rel2abs (override)
+
+Return an absolute file specification from a relative one.
+
+=cut
+
+sub rel2abs {
+ my $self = shift ;
+ my ($path,$base ) = @_;
+ return undef unless defined $path;
+
+ my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
+
+ # We need to identify what the directory is in
+ # of the specification in order to process them
+ my $path_unix = 0;
+ $path_unix = 1 if ($path =~ m#/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ my $path_vms = 0;
+ $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+
+ my $unix_mode = 0;
+ if ($path_vms == $path_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = $path_unix;
+ }
+
+ my $base_unix = 0;
+ my $base_vms = 0;
+
+ if (defined $base) {
+ $base_unix = 1 if ($base =~ m#/#);
+ $base_unix = 1 if ($base =~ /^\.\.?$/);
+ $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
+ $base_vms = 1 if ($base =~ /^--?$/);
+
+ # If we could not determine the path mode, see if we can find out
+ # from the base.
+ if ($path_vms == $path_unix) {
+ if ($base_vms != $base_unix) {
+ $unix_mode = $base_unix;
+ }
+ }
+ }
+
+ if (!$efs) {
+ # Legacy behavior, convert to VMS syntax.
+ $unix_mode = 0;
+ if (defined $base) {
+ $base = vmspath($base) if $base =~ m/\//;
+ }
+
+ if ($path =~ m/\//) {
+ $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
+ ? vmspath($path) # whether it's a directory
+ : vmsify($path) );
+ }
+ }
+
+ # Clean up and split up $path
+ if ( ! $self->file_name_is_absolute( $path ) ) {
+ # Figure out the effective $base and clean it up.
+ if ( !defined( $base ) || $base eq '' ) {
+ $base = $self->_cwd;
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ if ($efs) {
+ # base may have changed, so need to look up format again.
+ if ($unix_mode) {
+ $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
+ $base_vms = 1 if ($base =~ /^--?$/);
+ $base = unixpath($base) if $base_vms;
+ $base .= '/' unless ($base =~ m#/$#);
+ } else {
+ $base_unix = 1 if ($base =~ m#/#);
+ $base_unix = 1 if ($base =~ /^\.\.?$/);
+ $base = vmspath($base) if $base_unix;
+ }
+ }
+
+ # Split up paths
+ my ( $path_directories, $path_file ) =
+ ($self->splitpath( $path ))[1,2] ;
+
+ my ( $base_volume, $base_directories ) =
+ $self->splitpath( $base ) ;
+
+ $path_directories = '' if $path_directories eq '[]' ||
+ $path_directories eq '<>';
+ my $sep = '' ;
+
+ if ($efs) {
+ # Merge the paths assuming that the base is absolute.
+ $base_directories = $self->catdir('',
+ $base_directories,
+ $path_directories);
+ } else {
+ # Legacy behavior assumes VMS only paths
+ $sep = '.'
+ if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
+ $path_directories =~ m{^[^.\[<]}s
+ ) ;
+ $base_directories = "$base_directories$sep$path_directories";
+ $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
+ }
+
+ $path_file = '' if ($path_file eq '.') && $unix_mode;
+
+ $path = $self->catpath( $base_volume, $base_directories, $path_file );
+ }
+
+ return $self->canonpath( $path ) ;
+}
+
+
+# eliminate_macros() and fixpath() are MakeMaker-specific methods
+# which are used inside catfile() and catdir(). MakeMaker has its own
+# copies as of 6.06_03 which are the canonical ones. We leave these
+# here, in peace, so that File::Spec continues to work with MakeMakers
+# prior to 6.06_03.
+#
+# Please consider these two methods deprecated. Do not patch them,
+# patch the ones in ExtUtils::MM_VMS instead.
+#
+# Update: MakeMaker 6.48 is still using these routines on VMS.
+# so they need to be kept up to date with ExtUtils::MM_VMS.
+#
+# The traditional VMS mode using ODS-2 disks depends on these routines
+# being here. These routines should not be called in when the
+# C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
+
+sub eliminate_macros {
+ my($self,$path) = @_;
+ return '' unless (defined $path) && ($path ne '');
+ $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;
+}
+
+# Deprecated. See the note above for eliminate_macros().
+
+# 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.
+
+sub fixpath {
+ my($self,$path,$force_path) = @_;
+ return '' unless $path;
+ $self = bless {}, $self unless ref $self;
+ my($fixedpath,$prefix,$name);
+
+ if ($path =~ /\s/) {
+ return join ' ',
+ map { $self->fixpath($_,$force_path) }
+ split /\s+/, $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/^[^\[<]+//; }
+ $fixedpath;
+}
+
+
+=back
+
+=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.
+
+=head1 SEE ALSO
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+An explanation of VMS file specs can be found at
+L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm
new file mode 100644
index 00000000000..93301ac7357
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm
@@ -0,0 +1,444 @@
+package File::Spec::Win32;
+
+use strict;
+
+use vars qw(@ISA $VERSION);
+require File::Spec::Unix;
+
+$VERSION = '3.30';
+$VERSION = eval $VERSION;
+
+@ISA = qw(File::Spec::Unix);
+
+# Some regexes we use for path splitting
+my $DRIVE_RX = '[a-zA-Z]:';
+my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
+my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
+
+
+=head1 NAME
+
+File::Spec::Win32 - methods for Win32 file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::Win32; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=over 4
+
+=item devnull
+
+Returns a string representation of the null device.
+
+=cut
+
+sub devnull {
+ return "nul";
+}
+
+sub rootdir { '\\' }
+
+
+=item tmpdir
+
+Returns a string representation of the first existing directory
+from the following list:
+
+ $ENV{TMPDIR}
+ $ENV{TEMP}
+ $ENV{TMP}
+ SYS:/temp
+ C:\system\temp
+ C:/temp
+ /tmp
+ /
+
+The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
+for Symbian (the File::Spec::Win32 is used also for those platforms).
+
+Since Perl 5.8.0, if running under taint mode, and if the environment
+variables are tainted, they are not used.
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+ return $tmpdir if defined $tmpdir;
+ $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
+ 'SYS:/temp',
+ 'C:\system\temp',
+ 'C:/temp',
+ '/tmp',
+ '/' );
+}
+
+=item case_tolerant
+
+MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
+indicating the case significance when comparing file specifications.
+Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
+See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
+Default: 1
+
+=cut
+
+sub case_tolerant {
+ eval { require Win32API::File; } or return 1;
+ my $drive = shift || "C:";
+ my $osFsType = "\0"x256;
+ my $osVolName = "\0"x256;
+ my $ouFsFlags = 0;
+ Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
+ if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
+ else { return 1; }
+}
+
+=item file_name_is_absolute
+
+As of right now, this returns 2 if the path is absolute with a
+volume, 1 if it's absolute with no volume, 0 otherwise.
+
+=cut
+
+sub file_name_is_absolute {
+
+ my ($self,$file) = @_;
+
+ if ($file =~ m{^($VOL_RX)}o) {
+ my $vol = $1;
+ return ($vol =~ m{^$UNC_RX}o ? 2
+ : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
+ : 0);
+ }
+ return $file =~ m{^[\\/]} ? 1 : 0;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ shift;
+
+ # Legacy / compatibility support
+ #
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ # Compatibility with File::Spec <= 3.26:
+ # catfile('A:', 'foo') should return 'A:\foo'.
+ return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
+ if $_[0] =~ m{^$DRIVE_RX\z}o;
+
+ return _canon_cat( @_ );
+}
+
+sub catdir {
+ shift;
+
+ # Legacy / compatibility support
+ #
+ return ""
+ unless @_;
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ # Compatibility with File::Spec <= 3.26:
+ # catdir('A:', 'foo') should return 'A:\foo'.
+ return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
+ if $_[0] =~ m{^$DRIVE_RX\z}o;
+
+ return _canon_cat( @_ );
+}
+
+sub path {
+ my @path = split(';', $ENV{PATH});
+ s/"//g for @path;
+ @path = grep length, @path;
+ unshift(@path, ".");
+ return @path;
+}
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+On Win32 makes
+
+ dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
+ dir1\dir2\dir3\...\dir4 -> \dir\dir4
+
+=cut
+
+sub canonpath {
+ # Legacy / compatibility support
+ #
+ return $_[1] if !defined($_[1]) or $_[1] eq '';
+ return _canon_cat( $_[1] );
+}
+
+=item splitpath
+
+ ($volume,$directories,$file) = File::Spec->splitpath( $path );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path into volume, directory, and filename portions. Assumes that
+the last file is a path unless the path ends in '\\', '\\.', '\\..'
+or $no_file is true. On Win32 this means that $no_file true makes this return
+( $volume, $path, '' ).
+
+Separators accepted are \ and /.
+
+Volumes can be drive letters or UNC sharenames (\\server\share).
+
+The results can be passed to L</catpath> to get back a path equivalent to
+(usually identical to) the original path.
+
+=cut
+
+sub splitpath {
+ my ($self,$path, $nofile) = @_;
+ my ($volume,$directory,$file) = ('','','');
+ if ( $nofile ) {
+ $path =~
+ m{^ ( $VOL_RX ? ) (.*) }sox;
+ $volume = $1;
+ $directory = $2;
+ }
+ else {
+ $path =~
+ m{^ ( $VOL_RX ? )
+ ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
+ (.*)
+ }sox;
+ $volume = $1;
+ $directory = $2;
+ $file = $3;
+ }
+
+ return ($volume,$directory,$file);
+}
+
+
+=item splitdir
+
+The opposite of L<catdir()|File::Spec/catdir()>.
+
+ @dirs = File::Spec->splitdir( $directories );
+
+$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, leading empty and
+trailing directory entries can be returned, because these are significant
+on some OSs. So,
+
+ File::Spec->splitdir( "/a/b/c" );
+
+Yields:
+
+ ( '', 'a', 'b', '', 'c', '' )
+
+=cut
+
+sub splitdir {
+ my ($self,$directories) = @_ ;
+ #
+ # split() likes to forget about trailing null fields, so here we
+ # check to be sure that there will not be any before handling the
+ # simple case.
+ #
+ if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
+ return split( m|[\\/]|, $directories );
+ }
+ else {
+ #
+ # since there was a trailing separator, add a file name to the end,
+ # then do the split, then replace it with ''.
+ #
+ my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
+ $directories[ $#directories ]= '' ;
+ return @directories ;
+ }
+}
+
+
+=item catpath
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, $volume is ignored, and this is just like catfile(). On other OSs,
+the $volume become significant.
+
+=cut
+
+sub catpath {
+ my ($self,$volume,$directory,$file) = @_;
+
+ # If it's UNC, make sure the glue separator is there, reusing
+ # whatever separator is first in the $volume
+ my $v;
+ $volume .= $v
+ if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
+ $directory =~ m@^[^\\/]@s
+ ) ;
+
+ $volume .= $directory ;
+
+ # If the volume is not just A:, make sure the glue separator is
+ # there, reusing whatever separator is first in the $volume if possible.
+ if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
+ $volume =~ m@[^\\/]\Z(?!\n)@ &&
+ $file =~ m@[^\\/]@
+ ) {
+ $volume =~ m@([\\/])@ ;
+ my $sep = $1 ? $1 : '\\' ;
+ $volume .= $sep ;
+ }
+
+ $volume .= $file ;
+
+ return $volume ;
+}
+
+sub _same {
+ lc($_[1]) eq lc($_[2]);
+}
+
+sub rel2abs {
+ my ($self,$path,$base ) = @_;
+
+ my $is_abs = $self->file_name_is_absolute($path);
+
+ # Check for volume (should probably document the '2' thing...)
+ return $self->canonpath( $path ) if $is_abs == 2;
+
+ if ($is_abs) {
+ # It's missing a volume, add one
+ my $vol = ($self->splitpath( $self->_cwd() ))[0];
+ return $self->canonpath( $vol . $path );
+ }
+
+ if ( !defined( $base ) || $base eq '' ) {
+ require Cwd ;
+ $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
+ $base = $self->_cwd() unless defined $base ;
+ }
+ elsif ( ! $self->file_name_is_absolute( $base ) ) {
+ $base = $self->rel2abs( $base ) ;
+ }
+ else {
+ $base = $self->canonpath( $base ) ;
+ }
+
+ my ( $path_directories, $path_file ) =
+ ($self->splitpath( $path, 1 ))[1,2] ;
+
+ my ( $base_volume, $base_directories ) =
+ $self->splitpath( $base, 1 ) ;
+
+ $path = $self->catpath(
+ $base_volume,
+ $self->catdir( $base_directories, $path_directories ),
+ $path_file
+ ) ;
+
+ return $self->canonpath( $path ) ;
+}
+
+=back
+
+=head2 Note For File::Spec::Win32 Maintainers
+
+Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004,2007 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.
+
+=head1 SEE ALSO
+
+See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
+implementation of these methods, not the semantics.
+
+=cut
+
+
+sub _canon_cat # @path -> path
+{
+ my ($first, @rest) = @_;
+
+ my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
+ ? ucfirst( $1 ).( $2 ? "\\" : "" )
+ : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
+ (?: [\\/] ([^\\/]+) )?
+ [\\/]? }{}xs # UNC volume
+ ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
+ : $first =~ s{ \A [\\/] }{}x # root dir
+ ? "\\"
+ : "";
+ my $path = join "\\", $first, @rest;
+
+ $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
+
+ # xx/././yy --> xx/yy
+ $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ \.
+ (?:\\\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}gx;
+
+ # XXX I do not know whether more dots are supported by the OS supporting
+ # this ... annotation (NetWare or symbian but not MSWin32).
+ # Then .... could easily become ../../.. etc:
+ # Replace \.\.\. by (\.\.\.+) and substitute with
+ # { $1 . ".." . "\\.." x (length($2)-2) }gex
+ # ... --> ../..
+ $path =~ s{ (\A|\\) # at begin or after a slash
+ \.\.\.
+ (?=\\|\z) # at end or followed by slash
+ }{$1..\\..}gx;
+ # xx\yy\..\zz --> xx\zz
+ while ( $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ [^\\]+ # rip this 'yy' off
+ \\\.\.
+ (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
+ (?<!\\\.\.\\\.\.) # do *not* replace \..\..
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}sx ) {}
+
+ $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
+ $path =~ s#\\\z##; # xx\ --> xx
+
+ if ( $volume =~ m#\\\z# )
+ { # <vol>\.. --> <vol>\
+ $path =~ s{ \A # at begin
+ \.\.
+ (?:\\\.\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ }{}x;
+
+ return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
+ if $path eq ""
+ and $volume =~ m#\A(\\\\.*)\\\z#s;
+ }
+ return $path ne "" || $volume ? $volume.$path : ".";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/File/Temp.pm b/Master/tlpkg/tlperl/lib/File/Temp.pm
new file mode 100644
index 00000000000..a2d4ae0759f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Temp.pm
@@ -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
+
+@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@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;
diff --git a/Master/tlpkg/tlperl/lib/File/Which.pm b/Master/tlpkg/tlperl/lib/File/Which.pm
new file mode 100644
index 00000000000..69e336b03bd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Which.pm
@@ -0,0 +1,254 @@
+package File::Which;
+
+use 5.004;
+use strict;
+use Exporter ();
+use File::Spec ();
+
+use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK};
+BEGIN {
+ $VERSION = '1.09';
+ @ISA = 'Exporter';
+ @EXPORT = 'which';
+ @EXPORT_OK = 'where';
+}
+
+use constant IS_VMS => ($^O eq 'VMS');
+use constant IS_MAC => ($^O eq 'MacOS');
+use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
+
+# For Win32 systems, stores the extensions used for
+# executable files
+# For others, the empty string is used
+# because 'perl' . '' eq 'perl' => easier
+my @PATHEXT = ('');
+if ( IS_DOS ) {
+ # WinNT. PATHEXT might be set on Cygwin, but not used.
+ if ( $ENV{PATHEXT} ) {
+ push @PATHEXT, split ';', $ENV{PATHEXT};
+ } else {
+ # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
+ push @PATHEXT, qw{.com .exe .bat};
+ }
+} elsif ( IS_VMS ) {
+ push @PATHEXT, qw{.exe .com};
+}
+
+sub which {
+ my ($exec) = @_;
+
+ return undef unless $exec;
+
+ my $all = wantarray;
+ my @results = ();
+
+ # check for aliases first
+ if ( IS_VMS ) {
+ my $symbol = `SHOW SYMBOL $exec`;
+ chomp($symbol);
+ unless ( $? ) {
+ return $symbol unless $all;
+ push @results, $symbol;
+ }
+ }
+ if ( IS_MAC ) {
+ my @aliases = split /\,/, $ENV{Aliases};
+ foreach my $alias ( @aliases ) {
+ # This has not been tested!!
+ # PPT which says MPW-Perl cannot resolve `Alias $alias`,
+ # let's just hope it's fixed
+ if ( lc($alias) eq lc($exec) ) {
+ chomp(my $file = `Alias $alias`);
+ last unless $file; # if it failed, just go on the normal way
+ return $file unless $all;
+ push @results, $file;
+ # we can stop this loop as if it finds more aliases matching,
+ # it'll just be the same result anyway
+ last;
+ }
+ }
+ }
+
+ my @path = File::Spec->path;
+ if ( IS_DOS or IS_VMS or IS_MAC ) {
+ unshift @path, File::Spec->curdir;
+ }
+
+ foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
+ for my $ext ( @PATHEXT ) {
+ my $file = $base.$ext;
+
+ # We don't want dirs (as they are -x)
+ next if -d $file;
+
+ if (
+ # Executable, normal case
+ -x _
+ or (
+ # MacOS doesn't mark as executable so we check -e
+ IS_MAC
+ ||
+ (
+ IS_DOS
+ and
+ grep {
+ $file =~ /$_\z/i
+ } @PATHEXT[1..$#PATHEXT]
+ )
+ # DOSish systems don't pass -x on
+ # non-exe/bat/com files. so we check -e.
+ # However, we don't want to pass -e on files
+ # that aren't in PATHEXT, like README.
+ and -e _
+ )
+ ) {
+ return $file unless $all;
+ push @results, $file;
+ }
+ }
+ }
+
+ if ( $all ) {
+ return @results;
+ } else {
+ return undef;
+ }
+}
+
+sub where {
+ # force wantarray
+ my @res = which($_[0]);
+ return @res;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Which - Portable implementation of the `which' utility
+
+=head1 SYNOPSIS
+
+ use File::Which; # exports which()
+ use File::Which qw(which where); # exports which() and where()
+
+ my $exe_path = which('perldoc');
+
+ my @paths = where('perl');
+ - Or -
+ my @paths = which('perl'); # an array forces search for all of them
+
+=head1 DESCRIPTION
+
+C<File::Which> was created to be able to get the paths to executable programs
+on systems under which the `which' program wasn't implemented in the shell.
+
+C<File::Which> searches the directories of the user's C<PATH> (as returned by
+C<File::Spec-E<gt>path()>), looking for executable files having the name
+specified as a parameter to C<which()>. Under Win32 systems, which do not have a
+notion of directly executable files, but uses special extensions such as C<.exe>
+and C<.bat> to identify them, C<File::Which> takes extra steps to assure that
+you will find the correct file (so for example, you might be searching for
+C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
+
+=head1 Steps Used on Win32, DOS, OS2 and VMS
+
+=head2 Windows NT
+
+Windows NT has a special environment variable called C<PATHEXT>, which is used
+by the shell to look for executable files. Usually, it will contain a list in
+the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
+environment variable, it parses the list and uses it as the different
+extensions.
+
+=head2 Windows 9x and other ancient Win/DOS/OS2
+
+This set of operating systems don't have the C<PATHEXT> variable, and usually
+you will find executable files there with the extensions C<.exe>, C<.bat> and
+(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
+under Win32 but does not find a C<PATHEXT> variable.
+
+=head2 VMS
+
+Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
+
+=head1 Functions
+
+=head2 which($short_exe_name)
+
+Exported by default.
+
+C<$short_exe_name> is the name used in the shell to call the program (for
+example, C<perl>).
+
+If it finds an executable with the name you specified, C<which()> will return
+the absolute path leading to this executable (for example, F</usr/bin/perl> or
+F<C:\Perl\Bin\perl.exe>).
+
+If it does I<not> find the executable, it returns C<undef>.
+
+If C<which()> is called in list context, it will return I<all> the
+matches.
+
+=head2 where($short_exe_name)
+
+Not exported by default.
+
+Same as C<which($short_exe_name)> in array context. Same as the
+C<`where'> utility, will return an array containing all the path names
+matching C<$short_exe_name>.
+
+=head1 BUGS AND CAVEATS
+
+Not tested on VMS or MacOS, although there is platform specific code
+for those. Anyone who haves a second would be very kind to send me a
+report of how it went.
+
+File::Spec adds the current directory to the front of PATH if on
+Win32, VMS or MacOS. I have no knowledge of those so don't know if the
+current directory is searced first or not. Could someone please tell
+me?
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
+
+For other issues, contact the maintainer.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
+
+Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
+(for the mod_perl site) and Win32-awareness by me, with slight modifications
+by Stas Bekman, then extracted to create C<File::Which>.
+
+Version 0.04 had some significant platform-related changes, taken from
+the Perl Power Tools C<`which'> implementation by Abigail with
+enhancements from Peter Prymmer. See
+L<http://www.perl.com/language/ppt/src/which/index.html> for more
+information.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<File::Spec>, L<which(1)>, Perl Power Tools:
+L<http://www.perl.com/language/ppt/index.html>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/File/stat.pm b/Master/tlpkg/tlperl/lib/File/stat.pm
new file mode 100644
index 00000000000..bdf3aad52a2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/stat.pm
@@ -0,0 +1,346 @@
+package File::stat;
+use 5.006;
+
+use strict;
+use warnings;
+use warnings::register;
+use Carp;
+
+BEGIN { *warnif = \&warnings::warnif }
+
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+our $VERSION = '1.02';
+
+my @fields;
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(stat lstat);
+ @fields = qw( $st_dev $st_ino $st_mode
+ $st_nlink $st_uid $st_gid
+ $st_rdev $st_size
+ $st_atime $st_mtime $st_ctime
+ $st_blksize $st_blocks
+ );
+ @EXPORT_OK = ( @fields, "stat_cando" );
+ %EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
+}
+use vars @fields;
+
+use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);
+
+BEGIN {
+ # These constants will croak on use if the platform doesn't define
+ # them. It's important to avoid inflicting that on the user.
+ no strict 'refs';
+ for (qw(suid sgid svtx)) {
+ my $val = eval { &{"Fcntl::S_I\U$_"} };
+ *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
+ }
+ for (qw(SOCK CHR BLK REG DIR FIFO LNK)) {
+ *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
+ ? \&{"Fcntl::S_IS$_"} : sub { "" };
+ }
+}
+
+# from doio.c
+sub _ingroup {
+
+ $^O eq "MacOS" and return 1;
+
+ my ($gid, $eff) = @_;
+
+ # I am assuming that since VMS doesn't have getgroups(2), $) will
+ # always only contain a single entry.
+ $^O eq "VMS" and return $_[0] == $);
+
+ my ($egid, @supp) = split " ", $);
+ my ($rgid) = split " ", $(;
+
+ $gid == ($eff ? $egid : $rgid) and return 1;
+ grep $gid == $_, @supp and return 1;
+
+ return "";
+}
+
+# VMS uses the Unix version of the routine, even though this is very
+# suboptimal. VMS has a permissions structure that doesn't really fit
+# into struct stat, and unlike on Win32 the normal -X operators respect
+# that, but unfortunately by the time we get here we've already lost the
+# information we need. It looks to me as though if we were to preserve
+# the st_devnam entry of vmsish.h's fake struct stat (which actually
+# holds the filename) it might be possible to do this right, but both
+# getting that value out of the struct (perl's stat doesn't return it)
+# and interpreting it later would require this module to have an XS
+# component (at which point we might as well just call Perl_cando and
+# have done with it).
+
+if (grep $^O eq $_, qw/os2 MSWin32 dos/) {
+
+ # from doio.c
+ *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
+}
+else {
+
+ # from doio.c
+ *cando = sub {
+ my ($s, $mode, $eff) = @_;
+ my $uid = $eff ? $> : $<;
+
+ $^O ne "VMS" and $uid == 0 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 ($stuid == $uid) {
+ $stmode & $mode and return 1;
+ }
+ elsif (_ingroup($stgid, $eff)) {
+ $stmode & ($mode >> 3) and return 1;
+ }
+ else {
+ $stmode & ($mode >> 6) and return 1;
+ }
+ return "";
+ };
+}
+
+# alias for those who don't like objects
+*stat_cando = \&cando;
+
+my %op = (
+ r => sub { cando($_[0], S_IRUSR, 1) },
+ w => sub { cando($_[0], S_IWUSR, 1) },
+ x => sub { cando($_[0], S_IXUSR, 1) },
+ o => sub { $_[0][4] == $> },
+
+ R => sub { cando($_[0], S_IRUSR, 0) },
+ W => sub { cando($_[0], S_IWUSR, 0) },
+ X => sub { cando($_[0], S_IXUSR, 0) },
+ O => sub { $_[0][4] == $< },
+
+ e => sub { 1 },
+ z => sub { $_[0][7] == 0 },
+ s => sub { $_[0][7] },
+
+ f => sub { S_ISREG ($_[0][2]) },
+ d => sub { S_ISDIR ($_[0][2]) },
+ l => sub { S_ISLNK ($_[0][2]) },
+ p => sub { S_ISFIFO($_[0][2]) },
+ S => sub { S_ISSOCK($_[0][2]) },
+ b => sub { S_ISBLK ($_[0][2]) },
+ c => sub { S_ISCHR ($_[0][2]) },
+
+ u => sub { _suid($_[0][2]) },
+ g => sub { _sgid($_[0][2]) },
+ k => sub { _svtx($_[0][2]) },
+
+ M => sub { ($^T - $_[0][9] ) / 86400 },
+ C => sub { ($^T - $_[0][10]) / 86400 },
+ A => sub { ($^T - $_[0][8] ) / 86400 },
+);
+
+use constant HINT_FILETEST_ACCESS => 0x00400000;
+
+# we need fallback=>1 or stringifying breaks
+use overload
+ fallback => 1,
+ -X => sub {
+ my ($s, $op) = @_;
+
+ if (index "rwxRWX", $op) {
+ (caller 0)[8] & HINT_FILETEST_ACCESS
+ and warnif("File::stat ignores use filetest 'access'");
+
+ $^O eq "VMS" and warnif("File::stat ignores VMS ACLs");
+
+ # It would be nice to have a warning about using -l on a
+ # non-lstat, but that would require an extra member in the
+ # object.
+ }
+
+ if ($op{$op}) {
+ return $op{$op}->($_[0]);
+ }
+ else {
+ croak "-$op is not implemented on a File::stat object";
+ }
+ };
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'File::stat' => [
+ map { $_ => '$' } qw{
+ dev ino mode nlink uid gid rdev size
+ atime mtime ctime blksize blocks
+ }
+];
+
+sub populate (@) {
+ return unless @_;
+ my $stob = new();
+ @$stob = (
+ $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
+ $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
+ = @_;
+ return $stob;
+}
+
+sub lstat ($) { populate(CORE::lstat(shift)) }
+
+sub stat ($) {
+ my $arg = shift;
+ my $st = populate(CORE::stat $arg);
+ return $st if defined $st;
+ my $fh;
+ {
+ local $!;
+ no strict 'refs';
+ require Symbol;
+ $fh = \*{ Symbol::qualify( $arg, caller() )};
+ return unless defined fileno $fh;
+ }
+ return populate(CORE::stat $fh);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::stat - by-name interface to Perl's built-in stat() functions
+
+=head1 SYNOPSIS
+
+ use File::stat;
+ $st = stat($file) or die "No $file: $!";
+ if ( ($st->mode & 0111) && $st->nlink > 1) ) {
+ print "$file is executable with lotsa links\n";
+ }
+
+ if ( -x $st ) {
+ print "$file is executable\n";
+ }
+
+ use Fcntl "S_IRUSR";
+ if ( $st->cando(S_IRUSR, 1) ) {
+ print "My effective uid can read $file\n";
+ }
+
+ use File::stat qw(:FIELDS);
+ stat($file) or die "No $file: $!";
+ if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
+ print "$file is executable with lotsa links\n";
+ }
+
+=head1 DESCRIPTION
+
+This module's default exports override the core stat()
+and lstat() functions, replacing them with versions that return
+"File::stat" objects. This object has methods that
+return the similarly named structure field name from the
+stat(2) function; namely,
+dev,
+ino,
+mode,
+nlink,
+uid,
+gid,
+rdev,
+size,
+atime,
+mtime,
+ctime,
+blksize,
+and
+blocks.
+
+As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
+overloading, so you can call filetest operators (C<-f>, C<-x>, and so
+on) on it. It also provides a C<< ->cando >> method, called like
+
+ $st->cando( ACCESS, EFFECTIVE )
+
+where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
+L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
+effective (true) or real (false) ids. The method interprets the C<mode>,
+C<uid> and C<gid> fields, and returns whether or not the current process
+would be allowed the specified access.
+
+If you don't want to use the objects, you may import the C<< ->cando >>
+method into your namespace as a regular function called C<stat_cando>.
+This takes an arrayref containing the return values of C<stat> or
+C<lstat> as its first argument, and interprets it for you.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your stat() and lstat() functions.) Access these fields as
+variables named with a preceding C<st_> in front their method names.
+Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
+the fields.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 BUGS
+
+As of Perl 5.8.0 after using this module you cannot use the implicit
+C<$_> or the special filehandle C<_> with stat() or lstat(), trying
+to do so leads into strange errors. The workaround is for C<$_> to
+be explicit
+
+ my $stat_obj = stat $_;
+
+and for C<_> to explicitly populate the object using the unexported
+and undocumented populate() function with CORE::stat():
+
+ my $stat_obj = File::stat::populate(CORE::stat(_));
+
+=head1 ERRORS
+
+=over 4
+
+=item -%s is not implemented on a File::stat object
+
+The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
+they require more information than just a stat buffer.
+
+=back
+
+=head1 WARNINGS
+
+These can all be disabled with
+
+ no warnings "File::stat";
+
+=over 4
+
+=item File::stat ignores use filetest 'access'
+
+You have tried to use one of the C<-rwxRWX> filetests with C<use
+filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
+just use the information in the C<mode> member as usual.
+
+=item File::stat ignores VMS ACLs
+
+VMS systems have a permissions structure that cannot be completely
+represented in a stat buffer, and unlike on other systems the builtin
+filetest operators respect this. The C<File::stat> overloads, however,
+do not, since the information required is not available.
+
+=back
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Filter/Simple.pm b/Master/tlpkg/tlperl/lib/Filter/Simple.pm
new file mode 100644
index 00000000000..135a75dc6fb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Filter/Simple.pm
@@ -0,0 +1,797 @@
+package Filter::Simple;
+
+use Text::Balanced ':ALL';
+
+use vars qw{ $VERSION @EXPORT };
+
+$VERSION = '0.84';
+
+use Filter::Util::Call;
+use Carp;
+
+@EXPORT = qw( FILTER FILTER_ONLY );
+
+
+sub import {
+ if (@_>1) { shift; goto &FILTER }
+ else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
+}
+
+sub fail {
+ croak "FILTER_ONLY: ", @_;
+}
+
+my $exql = sub {
+ my @bits = extract_quotelike $_[0], qr//;
+ return unless $bits[0];
+ return \@bits;
+};
+
+my $ncws = qr/\s+/;
+my $comment = qr/(?<![\$\@%])#.*/;
+my $ws = qr/(?:$ncws|$comment)+/;
+my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
+my $EOP = qr/\n\n|\Z/;
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $EOP
+ | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+
+my %extractor_for = (
+ quotelike => [ $ws, \&extract_variable, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [ $ws, { DONT_MATCH => $pod_or_DATA },
+ \&extract_variable,
+ $id, { DONT_MATCH => \&extract_quotelike } ],
+ code_no_comments
+ => [ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
+ \&extract_variable,
+ $id, { DONT_MATCH => \&extract_quotelike } ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ executable_no_comments
+ => [ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+
+my %selector_for = (
+ all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
+ executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
+ quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
+ regex => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
+ return $_->[0] unless $op =~ /^(qr|m|s)/
+ || !$op && ($ld eq '/' || $ld eq '?');
+ $_ = $pat;
+ $t->(@_);
+ $ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
+ return "$pre$ql";
+ };
+ },
+ string => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ local *args = \@_;
+ my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
+ return $_->[0] if $op =~ /^(qr|m)/
+ || !$op && ($ld1 eq '/' || $ld1 eq '?');
+ if (!$op || $op eq 'tr' || $op eq 'y') {
+ local *_ = \$str1;
+ $t->(@args);
+ }
+ if ($op =~ /^(tr|y|s)/) {
+ local *_ = \$str2;
+ $t->(@args);
+ }
+ my $result = "$pre$op$ld1$str1$rd1";
+ $result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
+ $result .= "$str2$rd2$flg";
+ return $result;
+ };
+ },
+);
+
+
+sub gen_std_filter_for {
+ my ($type, $transform) = @_;
+ return sub {
+ my $instr;
+ local @components;
+ for (extract_multiple($_,$extractor_for{$type})) {
+ if (ref()) { push @components, $_; $instr=0 }
+ elsif ($instr) { $components[-1] .= $_ }
+ else { push @components, $_; $instr=1 }
+ }
+ if ($type =~ /^code/) {
+ my $count = 0;
+ local $placeholder = qr/\Q$;\E(\C{4})\Q$;\E/;
+ my $extractor = qr/\Q$;\E(\C{4})\Q$;\E/;
+ $_ = join "",
+ map { ref $_ ? $;.pack('N',$count++).$; : $_ }
+ @components;
+ @components = grep { ref $_ } @components;
+ $transform->(@_);
+ s/$extractor/${$components[unpack('N',$1)]}/g;
+ }
+ else {
+ my $selector = $selector_for{$type}->($transform);
+ $_ = join "", map $selector->(@_), @components;
+ }
+ }
+};
+
+sub FILTER (&;$) {
+ my $caller = caller;
+ my ($filter, $terminator) = @_;
+ no warnings 'redefine';
+ *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
+}
+
+sub FILTER_ONLY {
+ my $caller = caller;
+ while (@_ > 1) {
+ my ($what, $how) = splice(@_, 0, 2);
+ fail "Unknown selector: $what"
+ unless exists $extractor_for{$what};
+ fail "Filter for $what is not a subroutine reference"
+ unless ref $how eq 'CODE';
+ push @transforms, gen_std_filter_for($what,$how);
+ }
+ my $terminator = shift;
+
+ my $multitransform = sub {
+ foreach my $transform ( @transforms ) {
+ $transform->(@_);
+ }
+ };
+ no warnings 'redefine';
+ *{"${caller}::import"} =
+ gen_filter_import($caller,$multitransform,$terminator);
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
+}
+
+my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
+
+sub gen_filter_import {
+ my ($class, $filter, $terminator) = @_;
+ my %terminator;
+ my $prev_import = *{$class."::import"}{CODE};
+ return sub {
+ my ($imported_class, @args) = @_;
+ my $def_terminator =
+ qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/;
+ if (!defined $terminator) {
+ $terminator{terminator} = $def_terminator;
+ }
+ elsif (!ref $terminator || ref $terminator eq 'Regexp') {
+ $terminator{terminator} = $terminator;
+ }
+ elsif (ref $terminator ne 'HASH') {
+ croak "Terminator must be specified as scalar or hash ref"
+ }
+ elsif (!exists $terminator->{terminator}) {
+ $terminator{terminator} = $def_terminator;
+ }
+ filter_add(
+ sub {
+ my ($status, $lastline);
+ my $count = 0;
+ my $data = "";
+ while ($status = filter_read()) {
+ return $status if $status < 0;
+ if ($terminator{terminator} &&
+ m/$terminator{terminator}/) {
+ $lastline = $_;
+ last;
+ }
+ $data .= $_;
+ $count++;
+ $_ = "";
+ }
+ return $count if not $count;
+ $_ = $data;
+ $filter->($imported_class, @args) unless $status < 0;
+ if (defined $lastline) {
+ if (defined $terminator{becomes}) {
+ $_ .= $terminator{becomes};
+ }
+ elsif ($lastline =~ $def_terminator) {
+ $_ .= $lastline;
+ }
+ }
+ return $count;
+ }
+ );
+ if ($prev_import) {
+ goto &$prev_import;
+ }
+ elsif ($class->isa('Exporter')) {
+ $class->export_to_level(1,@_);
+ }
+ }
+}
+
+sub gen_filter_unimport {
+ my ($class) = @_;
+ return sub {
+ filter_del();
+ goto &$prev_unimport if $prev_unimport;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Filter::Simple - Simplified source filtering
+
+
+=head1 SYNOPSIS
+
+ # in MyFilter.pm:
+
+ package MyFilter;
+
+ use Filter::Simple;
+
+ FILTER { ... };
+
+ # or just:
+ #
+ # use Filter::Simple sub { ... };
+
+ # in user's code:
+
+ use MyFilter;
+
+ # this code is filtered
+
+ no MyFilter;
+
+ # this code is not
+
+
+=head1 DESCRIPTION
+
+=head2 The Problem
+
+Source filtering is an immensely powerful feature of recent versions of Perl.
+It allows one to extend the language itself (e.g. the Switch module), to
+simplify the language (e.g. Language::Pythonesque), or to completely recast the
+language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
+the full power of Perl as its own, recursively applied, macro language.
+
+The excellent Filter::Util::Call module (by Paul Marquess) provides a
+usable Perl interface to source filtering, but it is often too powerful
+and not nearly as simple as it could be.
+
+To use the module it is necessary to do the following:
+
+=over 4
+
+=item 1.
+
+Download, build, and install the Filter::Util::Call module.
+(If you have Perl 5.7.1 or later, this is already done for you.)
+
+=item 2.
+
+Set up a module that does a C<use Filter::Util::Call>.
+
+=item 3.
+
+Within that module, create an C<import> subroutine.
+
+=item 4.
+
+Within the C<import> subroutine do a call to C<filter_add>, passing
+it either a subroutine reference.
+
+=item 5.
+
+Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
+to "prime" $_ with source code data from the source file that will
+C<use> your module. Check the status value returned to see if any
+source code was actually read in.
+
+=item 6.
+
+Process the contents of $_ to change the source code in the desired manner.
+
+=item 7.
+
+Return the status value.
+
+=item 8.
+
+If the act of unimporting your module (via a C<no>) should cause source
+code filtering to cease, create an C<unimport> subroutine, and have it call
+C<filter_del>. Make sure that the call to C<filter_read> or
+C<filter_read_exact> in step 5 will not accidentally read past the
+C<no>. Effectively this limits source code filters to line-by-line
+operation, unless the C<import> subroutine does some fancy
+pre-pre-parsing of the source code it's filtering.
+
+=back
+
+For example, here is a minimal source code filter in a module named
+BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
+to the sequence C<die 'BANG' if $BANG> in any piece of code following a
+C<use BANG;> statement (until the next C<no BANG;> statement, if any):
+
+ package BANG;
+
+ use Filter::Util::Call ;
+
+ sub import {
+ filter_add( sub {
+ my $caller = caller;
+ my ($status, $no_seen, $data);
+ while ($status = filter_read()) {
+ if (/^\s*no\s+$caller\s*;\s*?$/) {
+ $no_seen=1;
+ last;
+ }
+ $data .= $_;
+ $_ = "";
+ }
+ $_ = $data;
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g
+ unless $status < 0;
+ $_ .= "no $class;\n" if $no_seen;
+ return 1;
+ })
+ }
+
+ sub unimport {
+ filter_del();
+ }
+
+ 1 ;
+
+This level of sophistication puts filtering out of the reach of
+many programmers.
+
+
+=head2 A Solution
+
+The Filter::Simple module provides a simplified interface to
+Filter::Util::Call; one that is sufficient for most common cases.
+
+Instead of the above process, with Filter::Simple the task of setting up
+a source code filter is reduced to:
+
+=over 4
+
+=item 1.
+
+Download and install the Filter::Simple module.
+(If you have Perl 5.7.1 or later, this is already done for you.)
+
+=item 2.
+
+Set up a module that does a C<use Filter::Simple> and then
+calls C<FILTER { ... }>.
+
+=item 3.
+
+Within the anonymous subroutine or block that is passed to
+C<FILTER>, process the contents of $_ to change the source code in
+the desired manner.
+
+=back
+
+In other words, the previous example, would become:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+ 1 ;
+
+Note that the source code is passed as a single string, so any regex that
+uses C<^> or C<$> to detect line boundaries will need the C</m> flag.
+
+=head2 Disabling or changing <no> behaviour
+
+By default, the installed filter only filters up to a line consisting of one of
+the three standard source "terminators":
+
+ no ModuleName; # optional comment
+
+or:
+
+ __END__
+
+or:
+
+ __DATA__
+
+but this can be altered by passing a second argument to C<use Filter::Simple>
+or C<FILTER> (just remember: there's I<no> comma after the initial block when
+you use C<FILTER>).
+
+That second argument may be either a C<qr>'d regular expression (which is then
+used to match the terminator line), or a defined false value (which indicates
+that no terminator line should be looked for), or a reference to a hash
+(in which case the terminator is the value associated with the key
+C<'terminator'>.
+
+For example, to cause the previous filter to filter only up to a line of the
+form:
+
+ GNAB esu;
+
+you would write:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ qr/^\s*GNAB\s+esu\s*;\s*?$/;
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
+
+and to prevent the filter's being turned off in any way:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ ""; # or: 0
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => "" };
+
+B<Note that, no matter what you set the terminator pattern to,
+the actual terminator itself I<must> be contained on a single source line.>
+
+
+=head2 All-in-one interface
+
+Separating the loading of Filter::Simple:
+
+ use Filter::Simple;
+
+from the setting up of the filtering:
+
+ FILTER { ... };
+
+is useful because it allows other code (typically parser support code
+or caching variables) to be defined before the filter is invoked.
+However, there is often no need for such a separation.
+
+In those cases, it is easier to just append the filtering subroutine and
+any terminator specification directly to the C<use> statement that loads
+Filter::Simple, like so:
+
+ use Filter::Simple sub {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+This is exactly the same as:
+
+ use Filter::Simple;
+ BEGIN {
+ Filter::Simple::FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+ }
+
+except that the C<FILTER> subroutine is not exported by Filter::Simple.
+
+
+=head2 Filtering only specific components of source code
+
+One of the problems with a filter like:
+
+ use Filter::Simple;
+
+ FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
+
+is that it indiscriminately applies the specified transformation to
+the entire text of your source program. So something like:
+
+ warn 'BANG BANG, YOU'RE DEAD';
+ BANG BANG;
+
+will become:
+
+ warn 'die 'BANG' if $BANG, YOU'RE DEAD';
+ die 'BANG' if $BANG;
+
+It is very common when filtering source to only want to apply the filter
+to the non-character-string parts of the code, or alternatively to I<only>
+the character strings.
+
+Filter::Simple supports this type of filtering by automatically
+exporting the C<FILTER_ONLY> subroutine.
+
+C<FILTER_ONLY> takes a sequence of specifiers that install separate
+(and possibly multiple) filters that act on only parts of the source code.
+For example:
+
+ use Filter::Simple;
+
+ FILTER_ONLY
+ code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
+ quotelike => sub { s/BANG\s+BANG/CHITTY CHITTY/g };
+
+The C<"code"> subroutine will only be used to filter parts of the source
+code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
+subroutine only filters Perl quotelikes (including here documents).
+
+The full list of alternatives is:
+
+=over
+
+=item C<"code">
+
+Filters only those sections of the source code that are not quotelikes, POD, or
+C<__DATA__>.
+
+=item C<"code_no_comments">
+
+Filters only those sections of the source code that are not quotelikes, POD,
+comments, or C<__DATA__>.
+
+=item C<"executable">
+
+Filters only those sections of the source code that are not POD or C<__DATA__>.
+
+=item C<"executable_no_comments">
+
+Filters only those sections of the source code that are not POD, comments, or C<__DATA__>.
+
+=item C<"quotelike">
+
+Filters only Perl quotelikes (as interpreted by
+C<&Text::Balanced::extract_quotelike>).
+
+=item C<"string">
+
+Filters only the string literal parts of a Perl quotelike (i.e. the
+contents of a string literal, either half of a C<tr///>, the second
+half of an C<s///>).
+
+=item C<"regex">
+
+Filters only the pattern literal parts of a Perl quotelike (i.e. the
+contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
+
+=item C<"all">
+
+Filters everything. Identical in effect to C<FILTER>.
+
+=back
+
+Except for C<< FILTER_ONLY code => sub {...} >>, each of
+the component filters is called repeatedly, once for each component
+found in the source code.
+
+Note that you can also apply two or more of the same type of filter in
+a single C<FILTER_ONLY>. For example, here's a simple
+macro-preprocessor that is only applied within regexes,
+with a final debugging pass that prints the resulting source code:
+
+ use Regexp::Common;
+ FILTER_ONLY
+ regex => sub { s/!\[/[^/g },
+ regex => sub { s/%d/$RE{num}{int}/g },
+ regex => sub { s/%f/$RE{num}{real}/g },
+ all => sub { print if $::DEBUG };
+
+
+
+=head2 Filtering only the code parts of source code
+
+Most source code ceases to be grammatically correct when it is broken up
+into the pieces between string literals and regexes. So the C<'code'>
+and C<'code_no_comments'> component filter behave slightly differently
+from the other partial filters described in the previous section.
+
+Rather than calling the specified processor on each individual piece of
+code (i.e. on the bits between quotelikes), the C<'code...'> partial
+filters operate on the entire source code, but with the quotelike bits
+(and, in the case of C<'code_no_comments'>, the comments) "blanked out".
+
+That is, a C<'code...'> filter I<replaces> each quoted string, quotelike,
+regex, POD, and __DATA__ section with a placeholder. The
+delimiters of this placeholder are the contents of the C<$;> variable
+at the time the filter is applied (normally C<"\034">). The remaining
+four bytes are a unique identifier for the component being replaced.
+
+This approach makes it comparatively easy to write code preprocessors
+without worrying about the form or contents of strings, regexes, etc.
+
+For convenience, during a C<'code...'> filtering operation, Filter::Simple
+provides a package variable (C<$Filter::Simple::placeholder>) that
+contains a pre-compiled regex that matches any placeholder...and
+captures the identifier within the placeholder. Placeholders can be
+moved and re-ordered within the source code as needed.
+
+In addition, a second package variable (C<@Filter::Simple::components>)
+contains a list of the various pieces of C<$_>, as they were originally split
+up to allow placeholders to be inserted.
+
+Once the filtering has been applied, the original strings, regexes, POD,
+etc. are re-inserted into the code, by replacing each placeholder with
+the corresponding original component (from C<@components>). Note that
+this means that the C<@components> variable must be treated with extreme
+care within the filter. The C<@components> array stores the "back-
+translations" of each placeholder inserted into C<$_>, as well as the
+interstitial source code between placeholders. If the placeholder
+backtranslations are altered in C<@components>, they will be similarly
+changed when the placeholders are removed from C<$_> after the filter
+is complete.
+
+For example, the following filter detects concatenated pairs of
+strings/quotelikes and reverses the order in which they are
+concatenated:
+
+ package DemoRevCat;
+ use Filter::Simple;
+
+ FILTER_ONLY code => sub {
+ my $ph = $Filter::Simple::placeholder;
+ s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
+ };
+
+Thus, the following code:
+
+ use DemoRevCat;
+
+ my $str = "abc" . q(def);
+
+ print "$str\n";
+
+would become:
+
+ my $str = q(def)."abc";
+
+ print "$str\n";
+
+and hence print:
+
+ defabc
+
+
+=head2 Using Filter::Simple with an explicit C<import> subroutine
+
+Filter::Simple generates a special C<import> subroutine for
+your module (see L<"How it works">) which would normally replace any
+C<import> subroutine you might have explicitly declared.
+
+However, Filter::Simple is smart enough to notice your existing
+C<import> and Do The Right Thing with it.
+That is, if you explicitly define an C<import> subroutine in a package
+that's using Filter::Simple, that C<import> subroutine will still
+be invoked immediately after any filter you install.
+
+The only thing you have to remember is that the C<import> subroutine
+I<must> be declared I<before> the filter is installed. If you use C<FILTER>
+to install the filter:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple;
+
+ FILTER { s/(\w+)/\U$1/ };
+
+that will almost never be a problem, but if you install a filtering
+subroutine by passing it directly to the C<use Filter::Simple>
+statement:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple sub{ s/(\w+)/\U$1/ };
+
+then you must make sure that your C<import> subroutine appears before
+that C<use> statement.
+
+
+=head2 Using Filter::Simple and Exporter together
+
+Likewise, Filter::Simple is also smart enough
+to Do The Right Thing if you use Exporter:
+
+ package Switch;
+ use base Exporter;
+ use Filter::Simple;
+
+ @EXPORT = qw(switch case);
+ @EXPORT_OK = qw(given when);
+
+ FILTER { $_ = magic_Perl_filter($_) }
+
+Immediately after the filter has been applied to the source,
+Filter::Simple will pass control to Exporter, so it can do its magic too.
+
+Of course, here too, Filter::Simple has to know you're using Exporter
+before it applies the filter. That's almost never a problem, but if you're
+nervous about it, you can guarantee that things will work correctly by
+ensuring that your C<use base Exporter> always precedes your
+C<use Filter::Simple>.
+
+
+=head2 How it works
+
+The Filter::Simple module exports into the package that calls C<FILTER>
+(or C<use>s it directly) -- such as package "BANG" in the above example --
+two automagically constructed
+subroutines -- C<import> and C<unimport> -- which take care of all the
+nasty details.
+
+In addition, the generated C<import> subroutine passes its own argument
+list to the filtering subroutine, so the BANG.pm filter could easily
+be made parametric:
+
+ package BANG;
+
+ use Filter::Simple;
+
+ FILTER {
+ my ($die_msg, $var_name) = @_;
+ s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
+ };
+
+ # and in some user code:
+
+ use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
+
+
+The specified filtering subroutine is called every time a C<use BANG> is
+encountered, and passed all the source code following that call, up to
+either the next C<no BANG;> (or whatever terminator you've set) or the
+end of the source file, whichever occurs first. By default, any C<no
+BANG;> call must appear by itself on a separate line, or it is ignored.
+
+
+=head1 AUTHOR
+
+Damian Conway
+
+=head1 CONTACT
+
+Filter::Simple is now maintained by the Perl5-Porters.
+Please submit bug via the C<perlbug> tool that comes with your perl.
+For usage instructions, read C<perldoc perlbug> or possibly C<man perlbug>.
+For mostly anything else, please contact E<lt>perl5-porters@perl.orgE<gt>.
+
+Maintainer of the CPAN release is Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
+Contact him with technical difficulties with respect to the packaging of the
+CPAN module.
+
+Praise of the module, flowers, and presents still go to the author,
+Damian Conway E<lt>damian@conway.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (c) 2000-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.
diff --git a/Master/tlpkg/tlperl/lib/Filter/Util/Call.pm b/Master/tlpkg/tlperl/lib/Filter/Util/Call.pm
new file mode 100644
index 00000000000..1d1b2618f0e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Filter/Util/Call.pm
@@ -0,0 +1,498 @@
+
+# Call.pm
+#
+# Copyright (c) 1995-2009 Paul Marquess. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Filter::Util::Call ;
+
+require 5.005 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use warnings;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.08" ;
+
+sub filter_read_exact($)
+{
+ my ($size) = @_ ;
+ my ($left) = $size ;
+ my ($status) ;
+
+ croak ("filter_read_exact: size parameter must be > 0")
+ unless $size > 0 ;
+
+ # try to read a block which is exactly $size bytes long
+ while ($left and ($status = filter_read($left)) > 0) {
+ $left = $size - length $_ ;
+ }
+
+ # EOF with pending data is a special case
+ return 1 if $status == 0 and length $_ ;
+
+ return $status ;
+}
+
+sub filter_add($)
+{
+ my($obj) = @_ ;
+
+ # Did we get a code reference?
+ my $coderef = (ref $obj eq 'CODE') ;
+
+ # If the parameter isn't already a reference, make it one.
+ $obj = \$obj unless ref $obj ;
+
+ $obj = bless ($obj, (caller)[0]) unless $coderef ;
+
+ # finish off the installation of the filter in C.
+ Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
+}
+
+bootstrap Filter::Util::Call ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::Util::Call - Perl Source Filter Utility Module
+
+=head1 SYNOPSIS
+
+ use Filter::Util::Call ;
+
+=head1 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+An alternate interface to Filter::Util::Call is now available. See
+L<Filter::Simple> for more details.
+
+A I<Perl Source Filter> is implemented as a Perl module. The structure
+of the module can take one of two broadly similar formats. To
+distinguish between them, the first will be referred to as I<method
+filter> and the second as I<closure filter>.
+
+Here is a skeleton for the I<method filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+ filter_add([]) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ $status = filter_read() ;
+ $status ;
+ }
+
+ 1 ;
+
+and this is the equivalent skeleton for the I<closure filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+
+ filter_add(
+ sub
+ {
+ my($status) ;
+ $status = filter_read() ;
+ $status ;
+ } )
+ }
+
+ 1 ;
+
+To make use of either of the two filter modules above, place the line
+below in a Perl source file.
+
+ use MyFilter;
+
+In fact, the skeleton modules shown above are fully functional I<Source
+Filters>, albeit fairly useless ones. All they does is filter the
+source stream without modifying it at all.
+
+As you can see both modules have a broadly similar structure. They both
+make use of the C<Filter::Util::Call> module and both have an C<import>
+method. The difference between them is that the I<method filter>
+requires a I<filter> method, whereas the I<closure filter> gets the
+equivalent of a I<filter> method with the anonymous sub passed to
+I<filter_add>.
+
+To make proper use of the I<closure filter> shown above you need to
+have a good understanding of the concept of a I<closure>. See
+L<perlref> for more details on the mechanics of I<closures>.
+
+=head2 B<use Filter::Util::Call>
+
+The following functions are exported by C<Filter::Util::Call>:
+
+ filter_add()
+ filter_read()
+ filter_read_exact()
+ filter_del()
+
+=head2 B<import()>
+
+The C<import> method is used to create an instance of the filter. It is
+called indirectly by Perl when it encounters the C<use MyFilter> line
+in a source file (See L<perlfunc/import> for more details on
+C<import>).
+
+It will always have at least one parameter automatically passed by Perl
+- this corresponds to the name of the package. In the example above it
+will be C<"MyFilter">.
+
+Apart from the first parameter, import can accept an optional list of
+parameters. These can be used to pass parameters to the filter. For
+example:
+
+ use MyFilter qw(a b c) ;
+
+will result in the C<@_> array having the following values:
+
+ @_ [0] => "MyFilter"
+ @_ [1] => "a"
+ @_ [2] => "b"
+ @_ [3] => "c"
+
+Before terminating, the C<import> function must explicitly install the
+filter by calling C<filter_add>.
+
+B<filter_add()>
+
+The function, C<filter_add>, actually installs the filter. It takes one
+parameter which should be a reference. The kind of reference used will
+dictate which of the two filter types will be used.
+
+If a CODE reference is used then a I<closure filter> will be assumed.
+
+If a CODE reference is not used, a I<method filter> will be assumed.
+In a I<method filter>, the reference can be used to store context
+information. The reference will be I<blessed> into the package by
+C<filter_add>.
+
+See the filters at the end of this documents for examples of using
+context information using both I<method filters> and I<closure
+filters>.
+
+=head2 B<filter() and anonymous sub>
+
+Both the C<filter> method used with a I<method filter> and the
+anonymous sub used with a I<closure filter> is where the main
+processing for the filter is done.
+
+The big difference between the two types of filter is that the I<method
+filter> uses the object passed to the method to store any context data,
+whereas the I<closure filter> uses the lexical variables that are
+maintained by the closure.
+
+Note that the single parameter passed to the I<method filter>,
+C<$self>, is the same reference that was passed to C<filter_add>
+blessed into the filter's package. See the example filters later on for
+details of using C<$self>.
+
+Here is a list of the common features of the anonymous sub and the
+C<filter()> method.
+
+=over 5
+
+=item B<$_>
+
+Although C<$_> doesn't actually appear explicitly in the sample filters
+above, it is implicitly used in a number of places.
+
+Firstly, when either C<filter> or the anonymous sub are called, a local
+copy of C<$_> will automatically be created. It will always contain the
+empty string at this point.
+
+Next, both C<filter_read> and C<filter_read_exact> will append any
+source data that is read to the end of C<$_>.
+
+Finally, when C<filter> or the anonymous sub are finished processing,
+they are expected to return the filtered source using C<$_>.
+
+This implicit use of C<$_> greatly simplifies the filter.
+
+=item B<$status>
+
+The status value that is returned by the user's C<filter> method or
+anonymous sub and the C<filter_read> and C<read_exact> functions take
+the same set of values, namely:
+
+ < 0 Error
+ = 0 EOF
+ > 0 OK
+
+=item B<filter_read> and B<filter_read_exact>
+
+These functions are used by the filter to obtain either a line or block
+from the next filter in the chain or the actual source file if there
+aren't any other filters.
+
+The function C<filter_read> takes two forms:
+
+ $status = filter_read() ;
+ $status = filter_read($size) ;
+
+The first form is used to request a I<line>, the second requests a
+I<block>.
+
+In line mode, C<filter_read> will append the next source line to the
+end of the C<$_> scalar.
+
+In block mode, C<filter_read> will append a block of data which is <=
+C<$size> to the end of the C<$_> scalar. It is important to emphasise
+the that C<filter_read> will not necessarily read a block which is
+I<precisely> C<$size> bytes.
+
+If you need to be able to read a block which has an exact size, you can
+use the function C<filter_read_exact>. It works identically to
+C<filter_read> in block mode, except it will try to read a block which
+is exactly C<$size> bytes in length. The only circumstances when it
+will not return a block which is C<$size> bytes long is on EOF or
+error.
+
+It is I<very> important to check the value of C<$status> after I<every>
+call to C<filter_read> or C<filter_read_exact>.
+
+=item B<filter_del>
+
+The function, C<filter_del>, is used to disable the current filter. It
+does not affect the running of the filter. All it does is tell Perl not
+to call filter any more.
+
+See L<Example 4: Using filter_del> for details.
+
+=back
+
+=head1 EXAMPLES
+
+Here are a few examples which illustrate the key concepts - as such
+most of them are of little practical use.
+
+The C<examples> sub-directory has copies of all these filters
+implemented both as I<method filters> and as I<closure filters>.
+
+=head2 Example 1: A simple filter.
+
+Below is a I<method filter> which is hard-wired to replace all
+occurrences of the string C<"Joe"> to C<"Jim">. Not particularly
+Useful, but it is the first example and I wanted to keep it simple.
+
+ package Joe2Jim ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type) = @_ ;
+
+ filter_add(bless []) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ }
+
+ 1 ;
+
+Here is an example of using the filter:
+
+ use Joe2Jim ;
+ print "Where is Joe?\n" ;
+
+And this is what the script above will print:
+
+ Where is Jim?
+
+=head2 Example 2: Using the context
+
+The previous example was not particularly useful. To make it more
+general purpose we will make use of the context data and allow any
+arbitrary I<from> and I<to> strings to be used. This time we will use a
+I<closure filter>. To reflect its enhanced role, the filter is called
+C<Subst>.
+
+ package Subst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ croak("usage: use Subst qw(from to)")
+ unless @_ == 3 ;
+ my ($self, $from, $to) = @_ ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+ }
+ 1 ;
+
+and is used like this:
+
+ use Subst qw(Joe Jim) ;
+ print "Where is Joe?\n" ;
+
+
+=head2 Example 3: Using the context within the filter
+
+Here is a filter which a variation of the C<Joe2Jim> filter. As well as
+substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count
+of the number of substitutions made in the context object.
+
+Once EOF is detected (C<$status> is zero) the filter will insert an
+extra line into the source stream. When this extra line is executed it
+will print a count of the number of substitutions actually made.
+Note that C<$status> is set to C<1> in this case.
+
+ package Count ;
+
+ use Filter::Util::Call ;
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $$self ;
+ }
+ elsif ($$self >= 0) { # EOF
+ $_ = "print q[Made ${$self} substitutions\n]" ;
+ $status = 1 ;
+ $$self = -1 ;
+ }
+
+ $status ;
+ }
+
+ sub import
+ {
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(\$count) ;
+ }
+
+ 1 ;
+
+Here is a script which uses it:
+
+ use Count ;
+ print "Hello Joe\n" ;
+ print "Where is Joe\n" ;
+
+Outputs:
+
+ Hello Jim
+ Where is Jim
+ Made 2 substitutions
+
+=head2 Example 4: Using filter_del
+
+Another variation on a theme. This time we will modify the C<Subst>
+filter to allow a starting and stopping pattern to be specified as well
+as the I<from> and I<to> patterns. If you know the I<vi> editor, it is
+the equivalent of this command:
+
+ :/start/,/stop/s/from/to/
+
+When used as a filter we want to invoke it like this:
+
+ use NewSubst qw(start stop from to) ;
+
+Here is the module.
+
+ package NewSubst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ my ($self, $start, $stop, $from, $to) = @_ ;
+ my ($found) = 0 ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @_ == 5 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $found = 1
+ if $found == 0 and /$start/ ;
+
+ if ($found) {
+ s/$from/$to/ ;
+ filter_del() if /$stop/ ;
+ }
+
+ }
+ $status ;
+ } )
+
+ }
+
+ 1 ;
+
+=head1 Filter::Simple
+
+If you intend using the Filter::Call functionality, I would strongly
+recommend that you check out Damian Conway's excellent Filter::Simple
+module. Damian's module provides a much cleaner interface than
+Filter::Util::Call. Although it doesn't allow the fine control that
+Filter::Util::Call does, it should be adequate for the majority of
+applications. It's available at
+
+ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+ http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Getopt/Long.pm b/Master/tlpkg/tlperl/lib/Getopt/Long.pm
new file mode 100644
index 00000000000..c827d3c39b3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Getopt/Long.pm
@@ -0,0 +1,2649 @@
+# Getopt::Long.pm -- Universal options parsing
+
+package Getopt::Long;
+
+# RCS Status : $Id: Long.pm,v 2.76 2009/03/30 20:54:30 jv 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);
+@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: 2.76 $', ") ",
+ "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(',',@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("|",@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@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
+
diff --git a/Master/tlpkg/tlperl/lib/Getopt/Std.pm b/Master/tlpkg/tlperl/lib/Getopt/Std.pm
new file mode 100644
index 00000000000..823bc4dd910
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Getopt/Std.pm
@@ -0,0 +1,295 @@
+package Getopt::Std;
+require 5.000;
+require Exporter;
+
+=head1 NAME
+
+getopt, getopts - Process single-character switches with switch clustering
+
+=head1 SYNOPSIS
+
+ use Getopt::Std;
+
+ getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect.
+ getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
+ getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
+ # Sets $opt_* as a side effect.
+ getopts('oif:', \%opts); # options as above. Values in %opts
+
+=head1 DESCRIPTION
+
+The getopt() function processes single-character switches with switch
+clustering. Pass one argument which is a string containing all switches
+that take an argument. For each switch found, sets $opt_x (where x is the
+switch name) to the value of the argument if an argument is expected,
+or 1 otherwise. Switches which take an argument don't care whether
+there is a space between the switch and the argument.
+
+The getopts() function is similar, but you should pass to it the list of all
+switches to be recognized. If unspecified switches are found on the
+command-line, the user will be warned that an unknown option was given.
+The getopts() function returns true unless an invalid option was found.
+
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, you will need to declare these package variables
+with "our":
+
+ our($opt_x, $opt_y);
+
+For those of you who don't like additional global variables being created, getopt()
+and getopts() will also accept a hash reference as an optional second argument.
+Hash keys will be x (where x is the switch name) with key values the value of
+the argument or 1 if no argument is specified.
+
+To allow programs to process arguments that look like switches, but aren't,
+both functions will stop processing switches when they see the argument
+C<-->. The C<--> will be removed from @ARGV.
+
+=head1 C<--help> and C<--version>
+
+If C<-> is not a recognized switch letter, getopts() supports arguments
+C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
+C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
+the output file handle, the name of option-processing package, its version,
+and the switches string. If the subroutines are not defined, an attempt is
+made to generate intelligent messages; for best results, define $main::VERSION.
+
+If embedded documentation (in pod format, see L<perlpod>) is detected
+in the script, C<--help> will also show how to access the documentation.
+
+Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
+isn't true (the default is false), then the messages are printed on STDERR,
+and the processing continues after the messages are printed. This being
+the opposite of the standard-conforming behaviour, it is strongly recommended
+to set $Getopt::Std::STANDARD_HELP_VERSION to true.
+
+One can change the output file handle of the messages by setting
+$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
+(without the C<Usage:> line) and C<--version> by calling functions help_mess()
+and version_mess() with the switches string as an argument.
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(getopt getopts);
+$VERSION = '1.06';
+# uncomment the next line to disable 1.03-backward compatibility paranoia
+# $STANDARD_HELP_VERSION = 1;
+
+# Process single-character switches with switch clustering. Pass one argument
+# which is a string containing all switches that take an argument. For each
+# switch found, sets $opt_x (where x is the switch name) to the value of the
+# argument, or 1 if no argument. Switches which take an argument don't care
+# whether there is a space between the switch and the argument.
+
+# Usage:
+# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub getopt (;$$) {
+ my ($argumentative, $hash) = @_;
+ $argumentative = '' if !defined $argumentative;
+ my ($first,$rest);
+ local $_;
+ local @EXPORT;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (/^--$/) { # early exit if --
+ shift @ARGV;
+ last;
+ }
+ if (index($argumentative,$first) >= 0) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+}
+
+sub output_h () {
+ return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
+ return \*STDOUT if $STANDARD_HELP_VERSION;
+ return \*STDERR;
+}
+
+sub try_exit () {
+ exit 0 if $STANDARD_HELP_VERSION;
+ my $p = __PACKAGE__;
+ print {output_h()} <<EOM;
+ [Now continuing due to backward compatibility and excessive paranoia.
+ See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
+EOM
+}
+
+sub version_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::VERSION_MESSAGE) {
+ main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my $v = $main::VERSION;
+ $v = '[unknown]' unless defined $v;
+ my $myv = $VERSION;
+ $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
+ my $perlv = $];
+ $perlv = sprintf "%vd", $^V if $] >= 5.006;
+ print $h <<EOH;
+$0 version $v calling Getopt::Std::getopts (version $myv),
+running under Perl version $perlv.
+EOH
+ }
+}
+
+sub help_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::HELP_MESSAGE) {
+ main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my (@witharg) = ($args =~ /(\S)\s*:/g);
+ my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
+ my ($help, $arg) = ('', '');
+ if (@witharg) {
+ $help .= "\n\tWith arguments: -" . join " -", @witharg;
+ $arg = "\nSpace is not required between options and their arguments.";
+ }
+ if (@rest) {
+ $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
+ }
+ my ($scr) = ($0 =~ m,([^/\\]+)$,);
+ print $h <<EOH if @_; # Let the script override this
+
+Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
+EOH
+ print $h <<EOH;
+
+The following single-character options are accepted:$help
+
+Options may be merged together. -- stops processing of options.$arg
+EOH
+ my $has_pod;
+ if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
+ and open my $script, '<', $0 ) {
+ while (<$script>) {
+ $has_pod = 1, last if /^=(pod|head1)/;
+ }
+ }
+ print $h <<EOH if $has_pod;
+
+For more details run
+ perldoc -F $0
+EOH
+ }
+}
+
+# Usage:
+# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+# # side effect.
+
+sub getopts ($;$) {
+ my ($argumentative, $hash) = @_;
+ my (@args,$first,$rest,$exit);
+ my $errs = 0;
+ local $_;
+ local @EXPORT;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
+ ($first,$rest) = ($1,$2);
+ if (/^--$/) { # early exit if --
+ shift @ARGV;
+ last;
+ }
+ my $pos = index($argumentative,$first);
+ if ($pos >= 0) {
+ if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
+ shift(@ARGV);
+ if ($rest eq '') {
+ ++$errs unless @ARGV;
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if ($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ if ($first eq '-' and $rest eq 'help') {
+ version_mess($argumentative, 'main');
+ help_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ } elsif ($first eq '-' and $rest eq 'version') {
+ version_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ }
+ warn "Unknown option: $first\n";
+ ++$errs;
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Hash/Util.pm b/Master/tlpkg/tlperl/lib/Hash/Util.pm
new file mode 100644
index 00000000000..0fa14690243
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Hash/Util.pm
@@ -0,0 +1,520 @@
+package Hash::Util;
+
+require 5.007003;
+use strict;
+use Carp;
+use warnings;
+use warnings::register;
+use Scalar::Util qw(reftype);
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(
+ fieldhash fieldhashes
+
+ all_keys
+ lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ lock_keys_plus hash_locked
+ hidden_keys legal_keys
+
+ lock_ref_keys unlock_ref_keys
+ lock_ref_value unlock_ref_value
+ lock_hashref unlock_hashref
+ lock_ref_keys_plus hashref_locked
+ hidden_ref_keys legal_ref_keys
+
+ hash_seed hv_store
+
+ );
+our $VERSION = 0.07;
+require DynaLoader;
+local @ISA = qw(DynaLoader);
+bootstrap Hash::Util $VERSION;
+
+sub import {
+ my $class = shift;
+ if ( grep /fieldhash/, @_ ) {
+ require Hash::Util::FieldHash;
+ Hash::Util::FieldHash->import(':all'); # for re-export
+ }
+ unshift @_, $class;
+ goto &Exporter::import;
+}
+
+
+=head1 NAME
+
+Hash::Util - A selection of general-utility hash subroutines
+
+=head1 SYNOPSIS
+
+ # Restricted hashes
+
+ use Hash::Util qw(
+ hash_seed all_keys
+ lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ lock_keys_plus hash_locked
+ hidden_keys legal_keys
+ );
+
+ %hash = (foo => 42, bar => 23);
+ # Ways to restrict a hash
+ lock_keys(%hash);
+ lock_keys(%hash, @keyset);
+ lock_keys_plus(%hash, @additional_keys);
+
+ # Ways to inspect the properties of a restricted hash
+ my @legal = legal_keys(%hash);
+ my @hidden = hidden_keys(%hash);
+ my $ref = all_keys(%hash,@keys,@hidden);
+ my $is_locked = hash_locked(%hash);
+
+ # Remove restrictions on the hash
+ unlock_keys(%hash);
+
+ # Lock individual values in a hash
+ lock_value (%hash, 'foo');
+ unlock_value(%hash, 'foo');
+
+ # Ways to change the restrictions on both keys and values
+ lock_hash (%hash);
+ unlock_hash(%hash);
+
+ my $hashes_are_randomised = hash_seed() != 0;
+
+=head1 DESCRIPTION
+
+C<Hash::Util> and C<Hash::Util::FieldHash> contain special functions
+for manipulating hashes that don't really warrant a keyword.
+
+C<Hash::Util> contains a set of functions that support
+L<restricted hashes|/"Restricted hashes">. These are described in
+this document. C<Hash::Util::FieldHash> contains an (unrelated)
+set of functions that support the use of hashes in
+I<inside-out classes>, described in L<Hash::Util::FieldHash>.
+
+By default C<Hash::Util> does not export anything.
+
+=head2 Restricted hashes
+
+5.8.0 introduces the ability to restrict a hash to a certain set of
+keys. No keys outside of this set can be added. It also introduces
+the ability to lock an individual key so it cannot be deleted and the
+ability to ensure that an individual value cannot be changed.
+
+This is intended to largely replace the deprecated pseudo-hashes.
+
+=over 4
+
+=item B<lock_keys>
+
+=item B<unlock_keys>
+
+ lock_keys(%hash);
+ lock_keys(%hash, @keys);
+
+Restricts the given %hash's set of keys to @keys. If @keys is not
+given it restricts it to its current keyset. No more keys can be
+added. delete() and exists() will still work, but will not alter
+the set of allowed keys. B<Note>: the current implementation prevents
+the hash from being bless()ed while it is in a locked state. Any attempt
+to do so will raise an exception. Of course you can still bless()
+the hash before you call lock_keys() so this shouldn't be a problem.
+
+ unlock_keys(%hash);
+
+Removes the restriction on the %hash's keyset.
+
+B<Note> that if any of the values of the hash have been locked they will not be unlocked
+after this sub executes.
+
+Both routines return a reference to the hash operated on.
+
+=cut
+
+sub lock_ref_keys {
+ my($hash, @keys) = @_;
+
+ Internals::hv_clear_placeholders %$hash;
+ if( @keys ) {
+ my %keys = map { ($_ => 1) } @keys;
+ my %original_keys = map { ($_ => 1) } keys %$hash;
+ foreach my $k (keys %original_keys) {
+ croak "Hash has key '$k' which is not in the new key set"
+ unless $keys{$k};
+ }
+
+ foreach my $k (@keys) {
+ $hash->{$k} = undef unless exists $hash->{$k};
+ }
+ Internals::SvREADONLY %$hash, 1;
+
+ foreach my $k (@keys) {
+ delete $hash->{$k} unless $original_keys{$k};
+ }
+ }
+ else {
+ Internals::SvREADONLY %$hash, 1;
+ }
+
+ return $hash;
+}
+
+sub unlock_ref_keys {
+ my $hash = shift;
+
+ Internals::SvREADONLY %$hash, 0;
+ return $hash;
+}
+
+sub lock_keys (\%;@) { lock_ref_keys(@_) }
+sub unlock_keys (\%) { unlock_ref_keys(@_) }
+
+=item B<lock_keys_plus>
+
+ lock_keys_plus(%hash,@additional_keys)
+
+Similar to C<lock_keys()>, with the difference being that the optional key list
+specifies keys that may or may not be already in the hash. Essentially this is
+an easier way to say
+
+ lock_keys(%hash,@additional_keys,keys %hash);
+
+Returns a reference to %hash
+
+=cut
+
+
+sub lock_ref_keys_plus {
+ my ($hash,@keys)=@_;
+ my @delete;
+ Internals::hv_clear_placeholders(%$hash);
+ foreach my $key (@keys) {
+ unless (exists($hash->{$key})) {
+ $hash->{$key}=undef;
+ push @delete,$key;
+ }
+ }
+ Internals::SvREADONLY(%$hash,1);
+ delete @{$hash}{@delete};
+ return $hash
+}
+
+sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
+
+
+=item B<lock_value>
+
+=item B<unlock_value>
+
+ lock_value (%hash, $key);
+ unlock_value(%hash, $key);
+
+Locks and unlocks the value for an individual key of a hash. The value of a
+locked key cannot be changed.
+
+Unless %hash has already been locked the key/value could be deleted
+regardless of this setting.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_ref_value {
+ my($hash, $key) = @_;
+ # I'm doubtful about this warning, as it seems not to be true.
+ # Marking a value in the hash as RO is useful, regardless
+ # of the status of the hash itself.
+ carp "Cannot usefully lock values in an unlocked hash"
+ if !Internals::SvREADONLY(%$hash) && warnings::enabled;
+ Internals::SvREADONLY $hash->{$key}, 1;
+ return $hash
+}
+
+sub unlock_ref_value {
+ my($hash, $key) = @_;
+ Internals::SvREADONLY $hash->{$key}, 0;
+ return $hash
+}
+
+sub lock_value (\%$) { lock_ref_value(@_) }
+sub unlock_value (\%$) { unlock_ref_value(@_) }
+
+
+=item B<lock_hash>
+
+=item B<unlock_hash>
+
+ lock_hash(%hash);
+
+lock_hash() locks an entire hash, making all keys and values read-only.
+No value can be changed, no keys can be added or deleted.
+
+ unlock_hash(%hash);
+
+unlock_hash() does the opposite of lock_hash(). All keys and values
+are made writable. All values can be changed and keys can be added
+and deleted.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref {
+ my $hash = shift;
+
+ lock_ref_keys($hash);
+
+ foreach my $value (values %$hash) {
+ Internals::SvREADONLY($value,1);
+ }
+
+ return $hash;
+}
+
+sub unlock_hashref {
+ my $hash = shift;
+
+ foreach my $value (values %$hash) {
+ Internals::SvREADONLY($value, 0);
+ }
+
+ unlock_ref_keys($hash);
+
+ return $hash;
+}
+
+sub lock_hash (\%) { lock_hashref(@_) }
+sub unlock_hash (\%) { unlock_hashref(@_) }
+
+=item B<lock_hash_recurse>
+
+=item B<unlock_hash_recurse>
+
+ lock_hash_recurse(%hash);
+
+lock_hash() locks an entire hash and any hashes it references recursively,
+making all keys and values read-only. No value can be changed, no keys can
+be added or deleted.
+
+B<Only> recurses into hashes that are referenced by another hash. Thus a
+Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of Hashes
+(HoAoH) will only have the top hash restricted.
+
+ unlock_hash_recurse(%hash);
+
+unlock_hash_recurse() does the opposite of lock_hash_recurse(). All keys and
+values are made writable. All values can be changed and keys can be added
+and deleted. Identical recursion restrictions apply as to lock_hash_recurse().
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref_recurse {
+ my $hash = shift;
+
+ lock_ref_keys($hash);
+ foreach my $value (values %$hash) {
+ if (reftype($value) eq 'HASH') {
+ lock_hashref_recurse($value);
+ }
+ Internals::SvREADONLY($value,1);
+ }
+ return $hash
+}
+
+sub unlock_hashref_recurse {
+ my $hash = shift;
+
+ foreach my $value (values %$hash) {
+ if (reftype($value) eq 'HASH') {
+ unlock_hashref_recurse($value);
+ }
+ Internals::SvREADONLY($value,1);
+ }
+ unlock_ref_keys($hash);
+ return $hash;
+}
+
+sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
+sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
+
+
+=item B<hash_unlocked>
+
+ hash_unlocked(%hash) and print "Hash is unlocked!\n";
+
+Returns true if the hash and its keys are unlocked.
+
+=cut
+
+sub hashref_unlocked {
+ my $hash=shift;
+ return Internals::SvREADONLY($hash)
+}
+
+sub hash_unlocked(\%) { hashref_unlocked(@_) }
+
+=for demerphqs_editor
+sub legal_ref_keys{}
+sub hidden_ref_keys{}
+sub all_keys{}
+
+=cut
+
+sub legal_keys(\%) { legal_ref_keys(@_) }
+sub hidden_keys(\%){ hidden_ref_keys(@_) }
+
+=item B<legal_keys>
+
+ my @keys = legal_keys(%hash);
+
+Returns the list of the keys that are legal in a restricted hash.
+In the case of an unrestricted hash this is identical to calling
+keys(%hash).
+
+=item B<hidden_keys>
+
+ my @keys = hidden_keys(%hash);
+
+Returns the list of the keys that are legal in a restricted hash but
+do not have a value associated to them. Thus if 'foo' is a
+"hidden" key of the %hash it will return false for both C<defined>
+and C<exists> tests.
+
+In the case of an unrestricted hash this will return an empty list.
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change, this routine may become meaningless, in which
+case it will return an empty list.
+
+=item B<all_keys>
+
+ all_keys(%hash,@keys,@hidden);
+
+Populates the arrays @keys with the all the keys that would pass
+an C<exists> tests, and populates @hidden with the remaining legal
+keys that have not been utilized.
+
+Returns a reference to the hash.
+
+In the case of an unrestricted hash this will be equivalent to
+
+ $ref = do {
+ @keys = keys %hash;
+ @hidden = ();
+ \%hash
+ };
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change this routine may become meaningless in which
+case it will behave identically to how it would behave on an
+unrestricted hash.
+
+=item B<hash_seed>
+
+ my $hash_seed = hash_seed();
+
+hash_seed() returns the seed number used to randomise hash ordering.
+Zero means the "traditional" random hash ordering, non-zero means the
+new even more random hash ordering introduced in Perl 5.8.1.
+
+B<Note that the hash seed is sensitive information>: by knowing it one
+can craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the hash seed> to people who don't need to know it.
+See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+
+=cut
+
+sub hash_seed () {
+ Internals::rehash_seed();
+}
+
+=item B<hv_store>
+
+ my $sv = 0;
+ hv_store(%hash,$key,$sv) or die "Failed to alias!";
+ $hash{$key} = 1;
+ print $sv; # prints 1
+
+Stores an alias to a variable in a hash instead of copying the value.
+
+=back
+
+=head2 Operating on references to hashes.
+
+Most subroutines documented in this module have equivalent versions
+that operate on references to hashes instead of native hashes.
+The following is a list of these subs. They are identical except
+in name and in that instead of taking a %hash they take a $hashref,
+and additionally are not prototyped.
+
+=over 4
+
+=item lock_ref_keys
+
+=item unlock_ref_keys
+
+=item lock_ref_keys_plus
+
+=item lock_ref_value
+
+=item unlock_ref_value
+
+=item lock_hashref
+
+=item unlock_hashref
+
+=item lock_hashref_recurse
+
+=item unlock_hashref_recurse
+
+=item hash_ref_unlocked
+
+=item legal_ref_keys
+
+=item hidden_ref_keys
+
+=back
+
+=head1 CAVEATS
+
+Note that the trapping of the restricted operations is not atomic:
+for example
+
+ eval { %hash = (illegal_key => 1) }
+
+leaves the C<%hash> empty rather than with its original contents.
+
+=head1 BUGS
+
+The interface exposed by this module is very close to the current
+implementation of restricted hashes. Over time it is expected that
+this behavior will be extended and the interface abstracted further.
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> on top of code by Nick
+Ing-Simmons and Jeffrey Friedl.
+
+hv_store() is from Array::RefElem, Copyright 2000 Gisle Aas.
+
+Additional code by Yves Orton.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util> and L<perlsec/"Algorithmic Complexity Attacks">.
+
+L<Hash::Util::FieldHash>.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm b/Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm
new file mode 100644
index 00000000000..bca3a6fd7fc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm
@@ -0,0 +1,860 @@
+package Hash::Util::FieldHash;
+
+use 5.009004;
+use strict;
+use warnings;
+use Scalar::Util qw( reftype);
+
+our $VERSION = '1.04';
+
+require Exporter;
+our @ISA = qw(Exporter);
+our %EXPORT_TAGS = (
+ 'all' => [ qw(
+ fieldhash
+ fieldhashes
+ idhash
+ idhashes
+ id
+ id_2obj
+ register
+ )],
+);
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+{
+ require XSLoader;
+ my %ob_reg; # private object registry
+ sub _ob_reg { \ %ob_reg }
+ XSLoader::load('Hash::Util::FieldHash', $VERSION);
+}
+
+sub fieldhash (\%) {
+ for ( shift ) {
+ return unless ref() && reftype( $_) eq 'HASH';
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0);
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 2) == 2;
+ return;
+ }
+}
+
+sub idhash (\%) {
+ for ( shift ) {
+ return unless ref() && reftype( $_) eq 'HASH';
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 0);
+ return $_ if Hash::Util::FieldHash::_fieldhash( $_, 1) == 1;
+ return;
+ }
+}
+
+sub fieldhashes { map &fieldhash( $_), @_ }
+sub idhashes { map &idhash( $_), @_ }
+
+1;
+__END__
+
+=head1 NAME
+
+Hash::Util::FieldHash - Support for Inside-Out Classes
+
+=head1 SYNOPSIS
+
+ ### Create fieldhashes
+ use Hash::Util qw(fieldhash fieldhashes);
+
+ # Create a single field hash
+ fieldhash my %foo;
+
+ # Create three at once...
+ fieldhashes \ my(%foo, %bar, %baz);
+ # ...or any number
+ fieldhashes @hashrefs;
+
+ ### Create an idhash and register it for garbage collection
+ use Hash::Util::FieldHash qw(idhash register);
+ idhash my %name;
+ my $object = \ do { my $o };
+ # register the idhash for garbage collection with $object
+ register($object, \ %name);
+ # the following entry will be deleted when $object goes out of scope
+ $name{$object} = 'John Doe';
+
+ ### Register an ordinary hash for garbage collection
+ use Hash::Util::FieldHash qw(id register);
+ my %name;
+ my $object = \ do { my $o };
+ # register the hash %name for garbage collection of $object's id
+ register $object, \ %name;
+ # the following entry will be deleted when $object goes out of scope
+ $name{id $object} = 'John Doe';
+
+=head1 FUNCTIONS
+
+C<Hash::Util::FieldHash> offers a number of functions in support of
+L<The Inside-out Technique> of class construction.
+
+=over
+
+=item id
+
+ id($obj)
+
+Returns the reference address of a reference $obj. If $obj is
+not a reference, returns $obj.
+
+This function is a stand-in replacement for
+L<Scalar::Util::refaddr|Scalar::Util/refaddr>, that is, it returns
+the reference address of its argument as a numeric value. The only
+difference is that C<refaddr()> returns C<undef> when given a
+non-reference while C<id()> returns its argument unchanged.
+
+C<id()> also uses a caching technique that makes it faster when
+the id of an object is requested often, but slower if it is needed
+only once or twice.
+
+=item id_2obj
+
+ $obj = id_2obj($id)
+
+If C<$id> is the id of a registered object (see L</register>), returns
+the object, otherwise an undefined value. For registered objects this
+is the inverse function of C<id()>.
+
+=item register
+
+ register($obj)
+ register($obj, @hashrefs)
+
+In the first form, registers an object to work with for the function
+C<id_2obj()>. In the second form, it additionally marks the given
+hashrefs down for garbage collection. This means that when the object
+goes out of scope, any entries in the given hashes under the key of
+C<id($obj)> will be deleted from the hashes.
+
+It is a fatal error to register a non-reference $obj. Any non-hashrefs
+among the following arguments are silently ignored.
+
+It is I<not> an error to register the same object multiple times with
+varying sets of hashrefs. Any hashrefs that are not registered yet
+will be added, others ignored.
+
+Registry also implies thread support. When a new thread is created,
+all references are replaced with new ones, including all objects.
+If a hash uses the reference address of an object as a key, that
+connection would be broken. With a registered object, its id will
+be updated in all hashes registered with it.
+
+=item idhash
+
+ idhash my %hash
+
+Makes an idhash from the argument, which must be a hash.
+
+An I<idhash> works like a normal hash, except that it stringifies a
+I<reference used as a key> differently. A reference is stringified
+as if the C<id()> function had been invoked on it, that is, its
+reference address in decimal is used as the key.
+
+=item idhashes
+
+ idhashes \ my(%hash, %gnash, %trash)
+ idhashes \ @hashrefs
+
+Creates many idhashes from its hashref arguments. Returns those
+arguments that could be converted or their number in scalar context.
+
+=item fieldhash
+
+ fieldhash %hash;
+
+Creates a single fieldhash. The argument must be a hash. Returns
+a reference to the given hash if successful, otherwise nothing.
+
+A I<fieldhash> is, in short, an idhash with auto-registry. When an
+object (or, indeed, any reference) is used as a fieldhash key, the
+fieldhash is automatically registered for garbage collection with
+the object, as if C<register $obj, \ %fieldhash> had been called.
+
+=item fieldhashes
+
+ fieldhashes @hashrefs;
+
+Creates any number of field hashes. Arguments must be hash references.
+Returns the converted hashrefs in list context, their number in scalar
+context.
+
+=back
+
+=head1 DESCRIPTION
+
+A word on terminology: I shall use the term I<field> for a scalar
+piece of data that a class associates with an object. Other terms that
+have been used for this concept are "object variable", "(object) property",
+"(object) attribute" and more. Especially "attribute" has some currency
+among Perl programmer, but that clashes with the C<attributes> pragma. The
+term "field" also has some currency in this sense and doesn't seem
+to conflict with other Perl terminology.
+
+In Perl, an object is a blessed reference. The standard way of associating
+data with an object is to store the data inside the object's body, that is,
+the piece of data pointed to by the reference.
+
+In consequence, if two or more classes want to access an object they
+I<must> agree on the type of reference and also on the organization of
+data within the object body. Failure to agree on the type results in
+immediate death when the wrong method tries to access an object. Failure
+to agree on data organization may lead to one class trampling over the
+data of another.
+
+This object model leads to a tight coupling between subclasses.
+If one class wants to inherit from another (and both classes access
+object data), the classes must agree about implementation details.
+Inheritance can only be used among classes that are maintained together,
+in a single source or not.
+
+In particular, it is not possible to write general-purpose classes
+in this technique, classes that can advertise themselves as "Put me
+on your @ISA list and use my methods". If the other class has different
+ideas about how the object body is used, there is trouble.
+
+For reference L<Name_hash> in L<Example 1> shows the standard implementation of
+a simple class C<Name> in the well-known hash based way. It also demonstrates
+the predictable failure to construct a common subclass C<NamedFile>
+of C<Name> and the class C<IO::File> (whose objects I<must> be globrefs).
+
+Thus, techniques are of interest that store object data I<not> in
+the object body but some other place.
+
+=head2 The Inside-out Technique
+
+With I<inside-out> classes, each class declares a (typically lexical)
+hash for each field it wants to use. The reference address of an
+object is used as the hash key. By definition, the reference address
+is unique to each object so this guarantees a place for each field that
+is private to the class and unique to each object. See L<Name_id> in
+L<Example 1> for a simple example.
+
+In comparison to the standard implementation where the object is a
+hash and the fields correspond to hash keys, here the fields correspond
+to hashes, and the object determines the hash key. Thus the hashes
+appear to be turned I<inside out>.
+
+The body of an object is never examined by an inside-out class, only
+its reference address is used. This allows for the body of an actual
+object to be I<anything at all> while the object methods of the class
+still work as designed. This is a key feature of inside-out classes.
+
+=head2 Problems of Inside-out
+
+Inside-out classes give us freedom of inheritance, but as usual there
+is a price.
+
+Most obviously, there is the necessity of retrieving the reference
+address of an object for each data access. It's a minor inconvenience,
+but it does clutter the code.
+
+More important (and less obvious) is the necessity of garbage
+collection. When a normal object dies, anything stored in the
+object body is garbage-collected by perl. With inside-out objects,
+Perl knows nothing about the data stored in field hashes by a class,
+but these must be deleted when the object goes out of scope. Thus
+the class must provide a C<DESTROY> method to take care of that.
+
+In the presence of multiple classes it can be non-trivial
+to make sure that every relevant destructor is called for
+every object. Perl calls the first one it finds on the
+inheritance tree (if any) and that's it.
+
+A related issue is thread-safety. When a new thread is created,
+the Perl interpreter is cloned, which implies that all reference
+addresses in use will be replaced with new ones. Thus, if a class
+tries to access a field of a cloned object its (cloned) data will
+still be stored under the now invalid reference address of the
+original in the parent thread. A general C<CLONE> method must
+be provided to re-establish the association.
+
+=head2 Solutions
+
+C<Hash::Util::FieldHash> addresses these issues on several
+levels.
+
+The C<id()> function is provided in addition to the
+existing C<Scalar::Util::refaddr()>. Besides its short name
+it can be a little faster under some circumstances (and a
+bit slower under others). Benchmark if it matters. The
+working of C<id()> also allows the use of the class name
+as a I<generic object> as described L<further down|/"The Generic Object">.
+
+The C<id()> function is incorporated in I<id hashes> in the sense
+that it is called automatically on every key that is used with
+the hash. No explicit call is necessary.
+
+The problems of garbage collection and thread safety are both
+addressed by the function C<register()>. It registers an object
+together with any number of hashes. Registry means that when the
+object dies, an entry in any of the hashes under the reference
+address of this object will be deleted. This guarantees garbage
+collection in these hashes. It also means that on thread
+cloning the object's entries in registered hashes will be
+replaced with updated entries whose key is the cloned object's
+reference address. Thus the object-data association becomes
+thread-safe.
+
+Object registry is best done when the object is initialized
+for use with a class. That way, garbage collection and thread
+safety are established for every object and every field that is
+initialized.
+
+Finally, I<field hashes> incorporate all these functions in one
+package. Besides automatically calling the C<id()> function
+on every object used as a key, the object is registered with
+the field hash on first use. Classes based on field hashes
+are fully garbage-collected and thread safe without further
+measures.
+
+=head2 More Problems
+
+Another problem that occurs with inside-out classes is serialization.
+Since the object data is not in its usual place, standard routines
+like C<Storable::freeze()>, C<Storable::thaw()> and
+C<Data::Dumper::Dumper()> can't deal with it on their own. Both
+C<Data::Dumper> and C<Storable> provide the necessary hooks to
+make things work, but the functions or methods used by the hooks
+must be provided by each inside-out class.
+
+A general solution to the serialization problem would require another
+level of registry, one that that associates I<classes> and fields.
+So far, the functions of C<Hash::Util::FieldHash> are unaware of
+any classes, which I consider a feature. Therefore C<Hash::Util::FieldHash>
+doesn't address the serialization problems.
+
+=head2 The Generic Object
+
+Classes based on the C<id()> function (and hence classes based on
+C<idhash()> and C<fieldhash()>) show a peculiar behavior in that
+the class name can be used like an object. Specifically, methods
+that set or read data associated with an object continue to work as
+class methods, just as if the class name were an object, distinct from
+all other objects, with its own data. This object may be called
+the I<generic object> of the class.
+
+This works because field hashes respond to keys that are not references
+like a normal hash would and use the string offered as the hash key.
+Thus, if a method is called as a class method, the field hash is presented
+with the class name instead of an object and blithely uses it as a key.
+Since the keys of real objects are decimal numbers, there is no
+conflict and the slot in the field hash can be used like any other.
+The C<id()> function behaves correspondingly with respect to non-reference
+arguments.
+
+Two possible uses (besides ignoring the property) come to mind.
+A singleton class could be implemented this using the generic object.
+If necessary, an C<init()> method could die or ignore calls with
+actual objects (references), so only the generic object will ever exist.
+
+Another use of the generic object would be as a template. It is
+a convenient place to store class-specific defaults for various
+fields to be used in actual object initialization.
+
+Usually, the feature can be entirely ignored. Calling I<object
+methods> as I<class methods> normally leads to an error and isn't used
+routinely anywhere. It may be a problem that this error isn't
+indicated by a class with a generic object.
+
+=head2 How to use Field Hashes
+
+Traditionally, the definition of an inside-out class contains a bare
+block inside which a number of lexical hashes are declared and the
+basic accessor methods defined, usually through C<Scalar::Util::refaddr>.
+Further methods may be defined outside this block. There has to be
+a DESTROY method and, for thread support, a CLONE method.
+
+When field hashes are used, the basic structure remains the same.
+Each lexical hash will be made a field hash. The call to C<refaddr>
+can be omitted from the accessor methods. DESTROY and CLONE methods
+are not necessary.
+
+If you have an existing inside-out class, simply making all hashes
+field hashes with no other change should make no difference. Through
+the calls to C<refaddr> or equivalent, the field hashes never get to
+see a reference and work like normal hashes. Your DESTROY (and
+CLONE) methods are still needed.
+
+To make the field hashes kick in, it is easiest to redefine C<refaddr>
+as
+
+ sub refaddr { shift }
+
+instead of importing it from C<Scalar::Util>. It should now be possible
+to disable DESTROY and CLONE. Note that while it isn't disabled,
+DESTROY will be called before the garbage collection of field hashes,
+so it will be invoked with a functional object and will continue to
+function.
+
+It is not desirable to import the functions C<fieldhash> and/or
+C<fieldhashes> into every class that is going to use them. They
+are only used once to set up the class. When the class is up and running,
+these functions serve no more purpose.
+
+If there are only a few field hashes to declare, it is simplest to
+
+ use Hash::Util::FieldHash;
+
+early and call the functions qualified:
+
+ Hash::Util::FieldHash::fieldhash my %foo;
+
+Otherwise, import the functions into a convenient package like
+C<HUF> or, more general, C<Aux>
+
+ {
+ package Aux;
+ use Hash::Util::FieldHash ':all';
+ }
+
+and call
+
+ Aux::fieldhash my %foo;
+
+as needed.
+
+=head2 Garbage-Collected Hashes
+
+Garbage collection in a field hash means that entries will "spontaneously"
+disappear when the object that created them disappears. That must be
+borne in mind, especially when looping over a field hash. If anything
+you do inside the loop could cause an object to go out of scope, a
+random key may be deleted from the hash you are looping over. That
+can throw the loop iterator, so it's best to cache a consistent snapshot
+of the keys and/or values and loop over that. You will still have to
+check that a cached entry still exists when you get to it.
+
+Garbage collection can be confusing when keys are created in a field hash
+from normal scalars as well as references. Once a reference is I<used> with
+a field hash, the entry will be collected, even if it was later overwritten
+with a plain scalar key (every positive integer is a candidate). This
+is true even if the original entry was deleted in the meantime. In fact,
+deletion from a field hash, and also a test for existence constitute
+I<use> in this sense and create a liability to delete the entry when
+the reference goes out of scope. If you happen to create an entry
+with an identical key from a string or integer, that will be collected
+instead. Thus, mixed use of references and plain scalars as field hash
+keys is not entirely supported.
+
+=head1 EXAMPLES
+
+The examples show a very simple class that implements a I<name>, consisting
+of a first and last name (no middle initial). The name class has four
+methods:
+
+=over
+
+=item * C<init()>
+
+An object method that initializes the first and last name to its
+two arguments. If called as a class method, C<init()> creates an
+object in the given class and initializes that.
+
+=item * C<first()>
+
+Retrieve the first name
+
+=item * C<last()>
+
+Retrieve the last name
+
+=item * C<name()>
+
+Retrieve the full name, the first and last name joined by a blank.
+
+=back
+
+The examples show this class implemented with different levels of
+support by C<Hash::Util::FieldHash>. All supported combinations
+are shown. The difference between implementations is often quite
+small. The implementations are:
+
+=over
+
+=item * C<Name_hash>
+
+A conventional (not inside-out) implementation where an object is
+a hash that stores the field values, without support by
+C<Hash::Util::FieldHash>. This implementation doesn't allow
+arbitrary inheritance.
+
+=item * C<Name_id>
+
+Inside-out implementation based on the C<id()> function. It needs
+a C<DESTROY> method. For thread support a C<CLONE> method (not shown)
+would also be needed. Instead of C<Hash::Util::FieldHash::id()> the
+function C<Scalar::Util::refaddr> could be used with very little
+functional difference. This is the basic pattern of an inside-out
+class.
+
+=item * C<Name_idhash>
+
+Idhash-based inside-out implementation. Like L<Name_id> it needs
+a C<DESTROY> method and would need C<CLONE> for thread support.
+
+=item * C<Name_id_reg>
+
+Inside-out implementation based on the C<id()> function with explicit
+object registry. No destructor is needed and objects are thread safe.
+
+=item * C<Name_idhash_reg>
+
+Idhash-based inside-out implementation with explicit object registry.
+No destructor is needed and objects are thread safe.
+
+=item * C<Name_fieldhash>
+
+FieldHash-based inside-out implementation. Object registry happens
+automatically. No destructor is needed and objects are thread safe.
+
+=back
+
+These examples are realized in the code below, which could be copied
+to a file F<Example.pm>.
+
+=head2 Example 1
+
+ use strict; use warnings;
+
+ {
+ package Name_hash; # standard implementation: the object is a hash
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless {}, $obj unless ref $obj;
+ $obj->{ first} = $first;
+ $obj->{ last} = $last;
+ $obj;
+ }
+
+ sub first { shift()->{ first} }
+ sub last { shift()->{ last} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ }
+
+ {
+ package Name_id;
+ use Hash::Util::FieldHash qw(id);
+
+ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ id $obj} = $first;
+ $last{ id $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ id shift()} }
+ sub last { $last{ id shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ sub DESTROY {
+ my $id = id shift;
+ delete $first{ $id};
+ delete $last{ $id};
+ }
+
+ }
+
+ {
+ package Name_idhash;
+ use Hash::Util::FieldHash;
+
+ Hash::Util::FieldHash::idhashes( \ my (%first, %last) );
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+
+ sub DESTROY {
+ my $n = shift;
+ delete $first{ $n};
+ delete $last{ $n};
+ }
+
+ }
+
+ {
+ package Name_id_reg;
+ use Hash::Util::FieldHash qw(id register);
+
+ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ register( $obj, \ (%first, %last) );
+ $first{ id $obj} = $first;
+ $last{ id $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ id shift()} }
+ sub last { $last{ id shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ {
+ package Name_idhash_reg;
+ use Hash::Util::FieldHash qw(register);
+
+ Hash::Util::FieldHash::idhashes \ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ register( $obj, \ (%first, %last) );
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ {
+ package Name_fieldhash;
+ use Hash::Util::FieldHash;
+
+ Hash::Util::FieldHash::fieldhashes \ my (%first, %last);
+
+ sub init {
+ my $obj = shift;
+ my ($first, $last) = @_;
+ # create an object if called as class method
+ $obj = bless \ my $o, $obj unless ref $obj;
+ $first{ $obj} = $first;
+ $last{ $obj} = $last;
+ $obj;
+ }
+
+ sub first { $first{ shift()} }
+ sub last { $last{ shift()} }
+
+ sub name {
+ my $n = shift;
+ join ' ' => $n->first, $n->last;
+ }
+ }
+
+ 1;
+
+To exercise the various implementations the script L<below|/"Example 2"> can
+be used.
+
+It sets up a class C<Name> that is a mirror of one of the implementation
+classes C<Name_hash>, C<Name_id>, ..., C<Name_fieldhash>. That determines
+which implementation is run.
+
+The script first verifies the function of the C<Name> class.
+
+In the second step, the free inheritability of the implementation
+(or lack thereof) is demonstrated. For this purpose it constructs
+a class called C<NamedFile> which is a common subclass of C<Name> and
+the standard class C<IO::File>. This puts inheritability to the test
+because objects of C<IO::File> I<must> be globrefs. Objects of C<NamedFile>
+should behave like a file opened for reading and also support the C<name()>
+method. This class juncture works with exception of the C<Name_hash>
+implementation, where object initialization fails because of the
+incompatibility of object bodies.
+
+=head2 Example 2
+
+ use strict; use warnings; $| = 1;
+
+ use Example;
+
+ {
+ package Name;
+ use base 'Name_id'; # define here which implementation to run
+ }
+
+
+ # Verify that the base package works
+ my $n = Name->init(qw(Albert Einstein));
+ print $n->name, "\n";
+ print "\n";
+
+ # Create a named file handle (See definition below)
+ my $nf = NamedFile->init(qw(/tmp/x Filomena File));
+ # use as a file handle...
+ for ( 1 .. 3 ) {
+ my $l = <$nf>;
+ print "line $_: $l";
+ }
+ # ...and as a Name object
+ print "...brought to you by ", $nf->name, "\n";
+ exit;
+
+
+ # Definition of NamedFile
+ package NamedFile;
+ use base 'Name';
+ use base 'IO::File';
+
+ sub init {
+ my $obj = shift;
+ my ($file, $first, $last) = @_;
+ $obj = $obj->IO::File::new() unless ref $obj;
+ $obj->open($file) or die "Can't read '$file': $!";
+ $obj->Name::init($first, $last);
+ }
+ __END__
+
+
+=head1 GUTS
+
+To make C<Hash::Util::FieldHash> work, there were two changes to
+F<perl> itself. C<PERL_MAGIC_uvar> was made avalaible for hashes,
+and weak references now call uvar C<get> magic after a weakref has been
+cleared. The first feature is used to make field hashes intercept
+their keys upon access. The second one triggers garbage collection.
+
+=head2 The C<PERL_MAGIC_uvar> interface for hashes
+
+C<PERL_MAGIC_uvar> I<get> magic is called from C<hv_fetch_common> and
+C<hv_delete_common> through the function C<hv_magic_uvar_xkey>, which
+defines the interface. The call happens for hashes with "uvar" magic
+if the C<ufuncs> structure has equal values in the C<uf_val> and C<uf_set>
+fields. Hashes are unaffected if (and as long as) these fields
+hold different values.
+
+Upon the call, the C<mg_obj> field will hold the hash key to be accessed.
+Upon return, the C<SV*> value in C<mg_obj> will be used in place of the
+original key in the hash access. The integer index value in the first
+parameter will be the C<action> value from C<hv_fetch_common>, or -1
+if the call is from C<hv_delete_common>.
+
+This is a template for a function suitable for the C<uf_val> field in
+a C<ufuncs> structure for this call. The C<uf_set> and C<uf_index>
+fields are irrelevant.
+
+ IV watch_key(pTHX_ IV action, SV* field) {
+ MAGIC* mg = mg_find(field, PERL_MAGIC_uvar);
+ SV* keysv = mg->mg_obj;
+ /* Do whatever you need to. If you decide to
+ supply a different key newkey, return it like this
+ */
+ sv_2mortal(newkey);
+ mg->mg_obj = newkey;
+ return 0;
+ }
+
+=head2 Weakrefs call uvar magic
+
+When a weak reference is stored in an C<SV> that has "uvar" magic, C<set>
+magic is called after the reference has gone stale. This hook can be
+used to trigger further garbage-collection activities associated with
+the referenced object.
+
+=head2 How field hashes work
+
+The three features of key hashes, I<key replacement>, I<thread support>,
+and I<garbage collection> are supported by a data structure called
+the I<object registry>. This is a private hash where every object
+is stored. An "object" in this sense is any reference (blessed or
+unblessed) that has been used as a field hash key.
+
+The object registry keeps track of references that have been used as
+field hash keys. The keys are generated from the reference address
+like in a field hash (though the registry isn't a field hash). Each
+value is a weak copy of the original reference, stored in an C<SV> that
+is itself magical (C<PERL_MAGIC_uvar> again). The magical structure
+holds a list (another hash, really) of field hashes that the reference
+has been used with. When the weakref becomes stale, the magic is
+activated and uses the list to delete the reference from all field
+hashes it has been used with. After that, the entry is removed from
+the object registry itself. Implicitly, that frees the magic structure
+and the storage it has been using.
+
+Whenever a reference is used as a field hash key, the object registry
+is checked and a new entry is made if necessary. The field hash is
+then added to the list of fields this reference has used.
+
+The object registry is also used to repair a field hash after thread
+cloning. Here, the entire object registry is processed. For every
+reference found there, the field hashes it has used are visited and
+the entry is updated.
+
+=head2 Internal function Hash::Util::FieldHash::_fieldhash
+
+ # test if %hash is a field hash
+ my $result = _fieldhash \ %hash, 0;
+
+ # make %hash a field hash
+ my $result = _fieldhash \ %hash, 1;
+
+C<_fieldhash> is the internal function used to create field hashes.
+It takes two arguments, a hashref and a mode. If the mode is boolean
+false, the hash is not changed but tested if it is a field hash. If
+the hash isn't a field hash the return value is boolean false. If it
+is, the return value indicates the mode of field hash. When called with
+a boolean true mode, it turns the given hash into a field hash of this
+mode, returning the mode of the created field hash. C<_fieldhash>
+does not erase the given hash.
+
+Currently there is only one type of field hash, and only the boolean
+value of the mode makes a difference, but that may change.
+
+=head1 AUTHOR
+
+Anno Siegel (ANNO) wrote the xs code and the changes in perl proper
+Jerry Hedden (JDHEDDEN) made it faster
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2007 by (Anno Siegel)
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.7 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/I18N/Collate.pm b/Master/tlpkg/tlperl/lib/I18N/Collate.pm
new file mode 100644
index 00000000000..decc86ce3fe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/I18N/Collate.pm
@@ -0,0 +1,196 @@
+package I18N::Collate;
+
+use strict;
+our $VERSION = '1.01';
+
+=head1 NAME
+
+I18N::Collate - compare 8-bit scalar data according to the current locale
+
+=head1 SYNOPSIS
+
+ use I18N::Collate;
+ setlocale(LC_COLLATE, 'locale-of-your-choice');
+ $s1 = I18N::Collate->new("scalar_data_1");
+ $s2 = I18N::Collate->new("scalar_data_2");
+
+=head1 DESCRIPTION
+
+ ***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+ ***
+
+This module provides you with objects that will collate
+according to your national character set, provided that the
+POSIX setlocale() function is supported on your system.
+
+You can compare $s1 and $s2 above with
+
+ $s1 le $s2
+
+to extract the data itself, you'll need a dereference: $$s1
+
+This module uses POSIX::setlocale(). The basic collation conversion is
+done by strxfrm() which terminates at NUL characters being a decent C
+routine. collate_xfrm() handles embedded NUL characters gracefully.
+
+The available locales depend on your operating system; try whether
+C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the
+direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or
+C<ls /usr/lib/locale>. Not all the locales that your vendor supports
+are necessarily installed: please consult your operating system's
+documentation and possibly your local system administration. The
+locale names are probably something like C<xx_XX.(ISO)?8859-N> or
+C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH)
+variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western
+European character set.
+
+=cut
+
+# I18N::Collate.pm
+#
+# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
+# Helsinki University of Technology, Finland
+#
+# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood
+# overloading magic much deeper than I and told
+# how to cut the size of this code by more than half.
+# (my first version did overload all of lt gt eq le ge cmp)
+#
+# Purpose: compare 8-bit scalar data according to the current locale
+#
+# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm()
+#
+# Exports: setlocale 1)
+# collate_xfrm 2)
+#
+# Overloads: cmp # 3)
+#
+# Usage: use I18N::Collate;
+# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4)
+# $s1 = I18N::Collate->("scalar_data_1");
+# $s2 = I18N::Collate->("scalar_data_2");
+#
+# now you can compare $s1 and $s2: $s1 le $s2
+# to extract the data itself, you need to deref: $$s1
+#
+# Notes:
+# 1) this uses POSIX::setlocale
+# 2) the basic collation conversion is done by strxfrm() which
+# terminates at NUL characters being a decent C routine.
+# collate_xfrm handles embedded NUL characters gracefully.
+# 3) due to cmp and overload magic, lt le eq ge gt work also
+# 4) the available locales depend on your operating system;
+# try whether "locale -a" shows them or man pages for
+# "locale" or "nlsinfo" work or the more direct
+# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls".
+# Not all the locales that your vendor supports
+# are necessarily installed: please consult your
+# operating system's documentation.
+# The locale names are probably something like
+# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N',
+# for example 'fr_CH.ISO8859-1' is the Swiss (CH)
+# variant of French (fr), ISO Latin (8859) 1 (-1)
+# which is the Western European character set.
+#
+# Updated: 19961005
+#
+# ---
+
+use POSIX qw(strxfrm LC_COLLATE);
+use warnings::register;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
+our @EXPORT_OK = qw();
+
+use overload qw(
+fallback 1
+cmp collate_cmp
+);
+
+our($LOCALE, $C);
+
+our $please_use_I18N_Collate_even_if_deprecated = 0;
+sub new {
+ my $new = $_[1];
+
+ if (warnings::enabled() && $] >= 5.003_06) {
+ unless ($please_use_I18N_Collate_even_if_deprecated) {
+ warnings::warn <<___EOD___;
+***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+***
+___EOD___
+ $please_use_I18N_Collate_even_if_deprecated++;
+ }
+ }
+
+ bless \$new;
+}
+
+sub setlocale {
+ my ($category, $locale) = @_[0,1];
+
+ POSIX::setlocale($category, $locale) if (defined $category);
+ # the current $LOCALE
+ $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || '';
+}
+
+sub C {
+ my $s = ${$_[0]};
+
+ $C->{$LOCALE}->{$s} = collate_xfrm($s)
+ unless (defined $C->{$LOCALE}->{$s}); # cache when met
+
+ $C->{$LOCALE}->{$s};
+}
+
+sub collate_xfrm {
+ my $s = $_[0];
+ my $x = '';
+
+ for (split(/(\000+)/, $s)) {
+ $x .= (/^\000/) ? $_ : strxfrm("$_\000");
+ }
+
+ $x;
+}
+
+sub collate_cmp {
+ &C($_[0]) cmp &C($_[1]);
+}
+
+# init $LOCALE
+
+&I18N::Collate::setlocale();
+
+1; # keep require happy
diff --git a/Master/tlpkg/tlperl/lib/I18N/LangTags.pm b/Master/tlpkg/tlperl/lib/I18N/LangTags.pm
new file mode 100644
index 00000000000..0bdc65fed1e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/I18N/LangTags.pm
@@ -0,0 +1,887 @@
+
+# Time-stamp: "2004-10-06 23:26:33 ADT"
+# Sean M. Burke <sburke@cpan.org>
+
+require 5.000;
+package I18N::LangTags;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw(is_language_tag same_language_tag
+ extract_language_tags super_languages
+ similarity_language_tag is_dialect_of
+ locale2language_tag alternate_language_tags
+ encode_language_tag panic_languages
+ implicate_supers
+ implicate_supers_strictly
+ );
+%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
+
+$VERSION = "0.35";
+
+sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
+
+
+=head1 NAME
+
+I18N::LangTags - functions for dealing with RFC3066-style language tags
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags();
+
+...or specify whichever of those functions you want to import, like so:
+
+ use I18N::LangTags qw(implicate_supers similarity_language_tag);
+
+All the exportable functions are listed below -- you're free to import
+only some, or none at all. By default, none are imported. If you
+say:
+
+ use I18N::LangTags qw(:ALL)
+
+...then all are exported. (This saves you from having to use
+something less obvious like C<use I18N::LangTags qw(/./)>.)
+
+If you don't import any of these functions, assume a C<&I18N::LangTags::>
+in front of all the function names in the following examples.
+
+=head1 DESCRIPTION
+
+Language tags are a formalism, described in RFC 3066 (obsoleting
+1766), for declaring what language form (language and possibly
+dialect) a given chunk of information is in.
+
+This library provides functions for common tasks involving language
+tags as they are needed in a variety of protocols and applications.
+
+Please see the "See Also" references for a thorough explanation
+of how to correctly use language tags.
+
+=over
+
+=cut
+
+###########################################################################
+
+=item * the function is_language_tag($lang1)
+
+Returns true iff $lang1 is a formally valid language tag.
+
+ is_language_tag("fr") is TRUE
+ is_language_tag("x-jicarilla") is FALSE
+ (Subtags can be 8 chars long at most -- 'jicarilla' is 9)
+
+ is_language_tag("sgn-US") is TRUE
+ (That's American Sign Language)
+
+ is_language_tag("i-Klikitat") is TRUE
+ (True without regard to the fact noone has actually
+ registered Klikitat -- it's a formally valid tag)
+
+ is_language_tag("fr-patois") is TRUE
+ (Formally valid -- altho descriptively weak!)
+
+ is_language_tag("Spanish") is FALSE
+ is_language_tag("french-patois") is FALSE
+ (No good -- first subtag has to match
+ /^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
+
+ is_language_tag("x-borg-prot2532") is TRUE
+ (Yes, subtags can contain digits, as of RFC3066)
+
+=cut
+
+sub is_language_tag {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = lc($_[0]);
+
+ return 0 if $tag eq "i" or $tag eq "x";
+ # Bad degenerate cases that the following
+ # regexp would erroneously let pass
+
+ return $tag =~
+ /^(?: # First subtag
+ [xi] | [a-z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-z0-9]{1,8} # subtag
+ )*
+ $/xs ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function extract_language_tags($whatever)
+
+Returns a list of whatever looks like formally valid language tags
+in $whatever. Not very smart, so don't get too creative with
+what you want to feed it.
+
+ extract_language_tags("fr, fr-ca, i-mingo")
+ returns: ('fr', 'fr-ca', 'i-mingo')
+
+ extract_language_tags("It's like this: I'm in fr -- French!")
+ returns: ('It', 'in', 'fr')
+ (So don't just feed it any old thing.)
+
+The output is untainted. If you don't know what tainting is,
+don't worry about it.
+
+=cut
+
+sub extract_language_tags {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($text) =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
+ $text =~
+ m/
+ \b
+ (?: # First subtag
+ [iIxX] | [a-zA-Z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-zA-Z0-9]{1,8} # subtag
+ )*
+ \b
+ /xsg
+ );
+}
+
+###########################################################################
+
+=item * the function same_language_tag($lang1, $lang2)
+
+Returns true iff $lang1 and $lang2 are acceptable variant tags
+representing the same language-form.
+
+ same_language_tag('x-kadara', 'i-kadara') is TRUE
+ (The x/i- alternation doesn't matter)
+ same_language_tag('X-KADARA', 'i-kadara') is TRUE
+ (...and neither does case)
+ same_language_tag('en', 'en-US') is FALSE
+ (all-English is not the SAME as US English)
+ same_language_tag('x-kadara', 'x-kadar') is FALSE
+ (these are totally unrelated tags)
+ same_language_tag('no-bok', 'nb') is TRUE
+ (no-bok is a legacy tag for nb (Norwegian Bokmal))
+
+C<same_language_tag> works by just seeing whether
+C<encode_language_tag($lang1)> is the same as
+C<encode_language_tag($lang2)>.
+
+(Yes, I know this function is named a bit oddly. Call it historic
+reasons.)
+
+=cut
+
+sub same_language_tag {
+ my $el1 = &encode_language_tag($_[0]);
+ return 0 unless defined $el1;
+ # this avoids the problem of
+ # encode_language_tag($lang1) eq and encode_language_tag($lang2)
+ # being true if $lang1 and $lang2 are both undef
+
+ return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function similarity_language_tag($lang1, $lang2)
+
+Returns an integer representing the degree of similarity between
+tags $lang1 and $lang2 (the order of which does not matter), where
+similarity is the number of common elements on the left,
+without regard to case and to x/i- alternation.
+
+ similarity_language_tag('fr', 'fr-ca') is 1
+ (one element in common)
+ similarity_language_tag('fr-ca', 'fr-FR') is 1
+ (one element in common)
+
+ similarity_language_tag('fr-CA-joual',
+ 'fr-CA-PEI') is 2
+ similarity_language_tag('fr-CA-joual', 'fr-CA') is 2
+ (two elements in common)
+
+ similarity_language_tag('x-kadara', 'i-kadara') is 1
+ (x/i- doesn't matter)
+
+ similarity_language_tag('en', 'x-kadar') is 0
+ similarity_language_tag('x-kadara', 'x-kadar') is 0
+ (unrelated tags -- no similarity)
+
+ similarity_language_tag('i-cree-syllabic',
+ 'i-cherokee-syllabic') is 0
+ (no B<leftmost> elements in common!)
+
+=cut
+
+sub similarity_language_tag {
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+ # And encode_language_tag takes care of the whole
+ # no-nyn==nn, i-hakka==zh-hakka, etc, things
+
+ # NB: (i-sil-...)? (i-sgn-...)?
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ my @l1_subtags = split('-', $lang1);
+ my @l2_subtags = split('-', $lang2);
+ my $similarity = 0;
+
+ while(@l1_subtags and @l2_subtags) {
+ if(shift(@l1_subtags) eq shift(@l2_subtags)) {
+ ++$similarity;
+ } else {
+ last;
+ }
+ }
+ return $similarity;
+}
+
+###########################################################################
+
+=item * the function is_dialect_of($lang1, $lang2)
+
+Returns true iff language tag $lang1 represents a subform of
+language tag $lang2.
+
+B<Get the order right! It doesn't work the other way around!>
+
+ is_dialect_of('en-US', 'en') is TRUE
+ (American English IS a dialect of all-English)
+
+ is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE
+ is_dialect_of('fr-CA-joual', 'fr') is TRUE
+ (Joual is a dialect of (a dialect of) French)
+
+ is_dialect_of('en', 'en-US') is FALSE
+ (all-English is a NOT dialect of American English)
+
+ is_dialect_of('fr', 'en-CA') is FALSE
+
+ is_dialect_of('en', 'en' ) is TRUE
+ is_dialect_of('en-US', 'en-US') is TRUE
+ (B<Note:> these are degenerate cases)
+
+ is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
+ (the x/i thing doesn't matter, nor does case)
+
+ is_dialect_of('nn', 'no') is TRUE
+ (because 'nn' (New Norse) is aliased to 'no-nyn',
+ as a special legacy case, and 'no-nyn' is a
+ subform of 'no' (Norwegian))
+
+=cut
+
+sub is_dialect_of {
+
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ return 1 if $lang1 eq $lang2;
+ return 0 if length($lang1) < length($lang2);
+
+ $lang1 .= '-';
+ $lang2 .= '-';
+ return
+ (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
+}
+
+###########################################################################
+
+=item * the function super_languages($lang1)
+
+Returns a list of language tags that are superordinate tags to $lang1
+-- it gets this by removing subtags from the end of $lang1 until
+nothing (or just "i" or "x") is left.
+
+ super_languages("fr-CA-joual") is ("fr-CA", "fr")
+
+ super_languages("en-AU") is ("en")
+
+ super_languages("en") is empty-list, ()
+
+ super_languages("i-cherokee") is empty-list, ()
+ ...not ("i"), which would be illegal as well as pointless.
+
+If $lang1 is not a valid language tag, returns empty-list in
+a list context, undef in a scalar context.
+
+A notable and rather unavoidable problem with this method:
+"x-mingo-tom" has an "x" because the whole tag isn't an
+IANA-registered tag -- but super_languages('x-mingo-tom') is
+('x-mingo') -- which isn't really right, since 'i-mingo' is
+registered. But this module has no way of knowing that. (But note
+that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
+
+More importantly, you assume I<at your peril> that superordinates of
+$lang1 are mutually intelligible with $lang1. Consider this
+carefully.
+
+=cut
+
+sub super_languages {
+ my $lang1 = $_[0];
+ return() unless defined($lang1) && &is_language_tag($lang1);
+
+ # a hack for those annoying new (2001) tags:
+ $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
+ $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
+ $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
+ # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
+
+ my @l1_subtags = split('-', $lang1);
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ # NB: (i-sil-...)?
+
+ my @supers = ();
+ foreach my $bit (@l1_subtags) {
+ push @supers,
+ scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
+ }
+ pop @supers if @supers;
+ shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
+ return reverse @supers;
+}
+
+###########################################################################
+
+=item * the function locale2language_tag($locale_identifier)
+
+This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
+and maps it to a language tag. If it's not mappable (as with,
+notably, "C" and "POSIX"), this returns empty-list in a list context,
+or undef in a scalar context.
+
+ locale2language_tag("en") is "en"
+
+ locale2language_tag("en_US") is "en-US"
+
+ locale2language_tag("en_US.ISO8859-1") is "en-US"
+
+ locale2language_tag("C") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+I'm not totally sure that locale names map satisfactorily to language
+tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED.
+
+The output is untainted. If you don't know what tainting is,
+don't worry about it.
+
+=cut
+
+sub locale2language_tag {
+ my $lang =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return $lang if &is_language_tag($lang); # like "en"
+
+ $lang =~ tr<_><->; # "en_US" -> en-US
+ $lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US
+ # it_IT.utf8@euro => it-IT
+
+ return $lang if &is_language_tag($lang);
+
+ return;
+}
+
+###########################################################################
+
+=item * the function encode_language_tag($lang1)
+
+This function, if given a language tag, returns an encoding of it such
+that:
+
+* tags representing different languages never get the same encoding.
+
+* tags representing the same language always get the same encoding.
+
+* an encoding of a formally valid language tag always is a string
+value that is defined, has length, and is true if considered as a
+boolean.
+
+Note that the encoding itself is B<not> a formally valid language tag.
+Note also that you cannot, currently, go from an encoding back to a
+language tag that it's an encoding of.
+
+Note also that you B<must> consider the encoded value as atomic; i.e.,
+you should not consider it as anything but an opaque, unanalysable
+string value. (The internals of the encoding method may change in
+future versions, as the language tagging standard changes over time.)
+
+C<encode_language_tag> returns undef if given anything other than a
+formally valid language tag.
+
+The reason C<encode_language_tag> exists is because different language
+tags may represent the same language; this is normally treatable with
+C<same_language_tag>, but consider this situation:
+
+You have a data file that expresses greetings in different languages.
+Its format is "[language tag]=[how to say 'Hello']", like:
+
+ en-US=Hiho
+ fr=Bonjour
+ i-mingo=Hau'
+
+And suppose you write a program that reads that file and then runs as
+a daemon, answering client requests that specify a language tag and
+then expect the string that says how to greet in that language. So an
+interaction looks like:
+
+ greeting-client asks: fr
+ greeting-server answers: Bonjour
+
+So far so good. But suppose the way you're implementing this is:
+
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{$lang} = $expr;
+ }
+ close(IN);
+
+at which point %greetings has the contents:
+
+ "en-US" => "Hiho"
+ "fr" => "Bonjour"
+ "i-mingo" => "Hau'"
+
+And suppose then that you answer client requests for language $wanted
+by just looking up $greetings{$wanted}.
+
+If the client asks for "fr", that will look up successfully in
+%greetings, to the value "Bonjour". And if the client asks for
+"i-mingo", that will look up successfully in %greetings, to the value
+"Hau'".
+
+But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
+lookup in %greetings fails. That's the Wrong Thing.
+
+You could instead do lookups on $wanted with:
+
+ use I18N::LangTags qw(same_language_tag);
+ my $response = '';
+ foreach my $l2 (keys %greetings) {
+ if(same_language_tag($wanted, $l2)) {
+ $response = $greetings{$l2};
+ last;
+ }
+ }
+
+But that's rather inefficient. A better way to do it is to start your
+program with:
+
+ use I18N::LangTags qw(encode_language_tag);
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{
+ encode_language_tag($lang)
+ } = $expr;
+ }
+ close(IN);
+
+and then just answer client requests for language $wanted by just
+looking up
+
+ $greetings{encode_language_tag($wanted)}
+
+And that does the Right Thing.
+
+=cut
+
+sub encode_language_tag {
+ # Only similarity_language_tag() is allowed to analyse encodings!
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = $_[0] || return undef;
+ return undef unless &is_language_tag($tag);
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+ $tag =~ s/^iw\b/he/i; # Hebrew
+ $tag =~ s/^in\b/id/i; # Indonesian
+ $tag =~ s/^cre\b/cr/i; # Cree
+ $tag =~ s/^jw\b/jv/i; # Javanese
+ $tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger
+ $tag =~ s/^[ix]-navajo\b/nv/i; # Navajo
+ $tag =~ s/^ji\b/yi/i; # Yiddish
+ # SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now,
+ # but maybe they're all so obscure I can ignore them. "Obscure"
+ # meaning either that the language is obscure, and/or that the
+ # XXX form was extant so briefly that it's unlikely it was ever
+ # used. I hope.
+ #
+ # These go FROM the simplex to complex form, to get
+ # similarity-comparison right. And that's okay, since
+ # similarity_language_tag is the only thing that
+ # analyzes our output.
+ $tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka
+ $tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal
+ $tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk
+
+ $tag =~ s/^[xiXI]-//s;
+ # Just lop off any leading "x/i-"
+
+ return "~" . uc($tag);
+}
+
+#--------------------------------------------------------------------------
+
+=item * the function alternate_language_tags($lang1)
+
+This function, if given a language tag, returns all language tags that
+are alternate forms of this language tag. (I.e., tags which refer to
+the same language.) This is meant to handle legacy tags caused by
+the minor changes in language tag standards over the years; and
+the x-/i- alternation is also dealt with.
+
+Note that this function does I<not> try to equate new (and never-used,
+and unusable)
+ISO639-2 three-letter tags to old (and still in use) ISO639-1
+two-letter equivalents -- like "ara" -> "ar" -- because
+"ara" has I<never> been in use as an Internet language tag,
+and RFC 3066 stipulates that it never should be, since a shorter
+tag ("ar") exists.
+
+Examples:
+
+ alternate_language_tags('no-bok') is ('nb')
+ alternate_language_tags('nb') is ('no-bok')
+ alternate_language_tags('he') is ('iw')
+ alternate_language_tags('iw') is ('he')
+ alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
+ alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
+ alternate_language_tags('en') is ()
+ alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
+ alternate_language_tags('x-klikitat') is ('i-klikitat')
+ alternate_language_tags('i-klikitat') is ('x-klikitat')
+
+This function returns empty-list if given anything other than a formally
+valid language tag.
+
+=cut
+
+my %alt = qw( i x x i I X X I );
+sub alternate_language_tags {
+ my $tag = $_[0];
+ return() unless &is_language_tag($tag);
+
+ my @em; # push 'em real goood!
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+
+ if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
+ } elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1";
+
+ } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
+ } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
+
+ } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
+ } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
+
+ } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
+ } elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1";
+
+ } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
+ } elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1";
+
+ } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
+ } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
+
+ } elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1";
+ } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
+
+ } elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1";
+ } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
+ }
+
+ push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
+ return @em;
+}
+
+###########################################################################
+
+{
+ # Init %Panic...
+
+ my @panic = ( # MUST all be lowercase!
+ # Only large ("national") languages make it in this list.
+ # If you, as a user, are so bizarre that the /only/ language
+ # you claim to accept is Galician, then no, we won't do you
+ # the favor of providing Catalan as a panic-fallback for
+ # you. Because if I start trying to add "little languages" in
+ # here, I'll just go crazy.
+
+ # Scandinavian lgs. All based on opinion and hearsay.
+ 'sv' => [qw(nb no da nn)],
+ 'da' => [qw(nb no sv nn)], # I guess
+ [qw(no nn nb)], [qw(no nn nb sv da)],
+ 'is' => [qw(da sv no nb nn)],
+ 'fo' => [qw(da is no nb nn sv)], # I guess
+
+ # I think this is about the extent of tolerable intelligibility
+ # among large modern Romance languages.
+ 'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
+ 'ca' => [qw(es pt it fr)],
+ 'es' => [qw(ca it fr pt)],
+ 'it' => [qw(es fr ca pt)],
+ 'fr' => [qw(es it ca pt)],
+
+ # Also assume that speakers of the main Indian languages prefer
+ # to read/hear Hindi over English
+ [qw(
+ as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
+ )] => 'hi',
+ # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
+ # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
+ # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
+ 'hi' => [qw(bn pa as or)],
+ # I welcome finer data for the other Indian languages.
+ # E.g., what should Oriya's list be, besides just Hindi?
+
+ # And the panic languages for English is, of course, nil!
+
+ # My guesses at Slavic intelligibility:
+ ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian
+ 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat
+ 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
+
+ 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
+
+ 'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
+
+ #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
+
+ );
+ my($k,$v);
+ while(@panic) {
+ ($k,$v) = splice(@panic,0,2);
+ foreach my $k (ref($k) ? @$k : $k) {
+ foreach my $v (ref($v) ? @$v : $v) {
+ push @{$Panic{$k} ||= []}, $v unless $k eq $v;
+ }
+ }
+ }
+}
+
+=item * the function @langs = panic_languages(@accept_languages)
+
+This function takes a list of 0 or more language
+tags that constitute a given user's Accept-Language list, and
+returns a list of tags for I<other> (non-super)
+languages that are probably acceptable to the user, to be
+used I<if all else fails>.
+
+For example, if a user accepts only 'ca' (Catalan) and
+'es' (Spanish), and the documents/interfaces you have
+available are just in German, Italian, and Chinese, then
+the user will most likely want the Italian one (and not
+the Chinese or German one!), instead of getting
+nothing. So C<panic_languages('ca', 'es')> returns
+a list containing 'it' (Italian).
+
+English ('en') is I<always> in the return list, but
+whether it's at the very end or not depends
+on the input languages. This function works by consulting
+an internal table that stipulates what common
+languages are "close" to each other.
+
+A useful construct you might consider using is:
+
+ @fallbacks = super_languages(@accept_languages);
+ push @fallbacks, panic_languages(
+ @accept_languages, @fallbacks,
+ );
+
+=cut
+
+sub panic_languages {
+ # When in panic or in doubt, run in circles, scream, and shout!
+ my(@out, %seen);
+ foreach my $t (@_) {
+ next unless $t;
+ next if $seen{$t}++; # so we don't return it or hit it again
+ # push @out, super_languages($t); # nah, keep that separate
+ push @out, @{ $Panic{lc $t} || next };
+ }
+ return grep !$seen{$_}++, @out, 'en';
+}
+
+#---------------------------------------------------------------------------
+#---------------------------------------------------------------------------
+
+=item * the function implicate_supers( ...languages... )
+
+This takes a list of strings (which are presumed to be language-tags;
+strings that aren't, are ignored); and after each one, this function
+inserts super-ordinate forms that don't already appear in the list.
+The original list, plus these insertions, is returned.
+
+In other words, it takes this:
+
+ pt-br de-DE en-US fr pt-br-janeiro
+
+and returns this:
+
+ pt-br pt de-DE de en-US en fr pt-br-janeiro
+
+This function is most useful in the idiom
+
+ implicate_supers( I18N::LangTags::Detect::detect() );
+
+(See L<I18N::LangTags::Detect>.)
+
+
+=item * the function implicate_supers_strictly( ...languages... )
+
+This works like C<implicate_supers> except that the implicated
+forms are added to the end of the return list.
+
+In other words, implicate_supers_strictly takes a list of strings
+(which are presumed to be language-tags; strings that aren't, are
+ignored) and after the whole given list, it inserts the super-ordinate forms
+of all given tags, minus any tags that already appear in the input list.
+
+In other words, it takes this:
+
+ pt-br de-DE en-US fr pt-br-janeiro
+
+and returns this:
+
+ pt-br de-DE en-US fr pt-br-janeiro pt de en
+
+The reason this function has "_strictly" in its name is that when
+you're processing an Accept-Language list according to the RFCs, if
+you interpret the RFCs quite strictly, then you would use
+implicate_supers_strictly, but for normal use (i.e., common-sense use,
+as far as I'm concerned) you'd use implicate_supers.
+
+=cut
+
+sub implicate_supers {
+ my @languages = grep is_language_tag($_), @_;
+ my %seen_encoded;
+ foreach my $lang (@languages) {
+ $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
+ }
+
+ my(@output_languages);
+ foreach my $lang (@languages) {
+ push @output_languages, $lang;
+ foreach my $s ( I18N::LangTags::super_languages($lang) ) {
+ # Note that super_languages returns the longest first.
+ last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
+ push @output_languages, $s;
+ }
+ }
+ return uniq( @output_languages );
+
+}
+
+sub implicate_supers_strictly {
+ my @tags = grep is_language_tag($_), @_;
+ return uniq( @_, map super_languages($_), @_ );
+}
+
+
+
+###########################################################################
+1;
+__END__
+
+=back
+
+=head1 ABOUT LOWERCASING
+
+I've considered making all the above functions that output language
+tags return all those tags strictly in lowercase. Having all your
+language tags in lowercase does make some things easier. But you
+might as well just lowercase as you like, or call
+C<encode_language_tag($lang1)> where appropriate.
+
+=head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
+
+In some future version of I18N::LangTags, I plan to include support
+for RFC2482-style language tags -- which are basically just normal
+language tags with their ASCII characters shifted into Plane 14.
+
+=head1 SEE ALSO
+
+* L<I18N::LangTags::List|I18N::LangTags::List>
+
+* RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the
+Identification of Languages". (Obsoletes RFC 1766)
+
+* RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on
+Character Sets and Languages".
+
+* RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter
+Value and Encoded Word Extensions: Character Sets, Languages, and
+Continuations".
+
+* RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>,
+"Language Tagging in Unicode Plain Text".
+
+* Locale::Codes, in
+C<http://www.perl.com/CPAN/modules/by-module/Locale/>
+
+* ISO 639-2, "Codes for the representation of names of languages",
+including two-letter and three-letter codes,
+C<http://www.loc.gov/standards/iso639-2/langcodes.html>
+
+* The IANA list of registered languages (hopefully up-to-date),
+C<http://www.iana.org/assignments/language-tags>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998+ 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.
+
+The programs and documentation in this dist are distributed in
+the hope that they will be useful, but without any warranty; without
+even the implied warranty of merchantability or fitness for a
+particular purpose.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm b/Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm
new file mode 100644
index 00000000000..87280b7b511
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm
@@ -0,0 +1,237 @@
+
+# Time-stamp: "2004-06-20 21:47:55 ADT"
+
+require 5;
+package I18N::LangTags::Detect;
+use strict;
+
+use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
+ $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
+
+BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
+ # define the constant 'DEBUG' at compile-time
+
+$VERSION = "1.04";
+@ISA = ();
+use I18N::LangTags qw(alternate_language_tags locale2language_tag);
+
+sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
+sub _normalize {
+ my(@languages) =
+ map lc($_),
+ grep $_,
+ map {; $_, alternate_language_tags($_) } @_;
+ return _uniq(@languages) if wantarray;
+ return $languages[0];
+}
+
+#---------------------------------------------------------------------------
+# The extent of our functional interface:
+
+sub detect () { return __PACKAGE__->ambient_langprefs; }
+
+#===========================================================================
+
+sub ambient_langprefs { # always returns things untainted
+ my $base_class = $_[0];
+
+ return $base_class->http_accept_langs
+ if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
+ # it's off in its own routine because it's complicated
+
+ # Not running as a CGI: try to puzzle out from the environment
+ my @languages;
+
+ foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
+ next unless $ENV{$envname};
+ DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
+ push @languages,
+ map locale2language_tag($_),
+ # if it's a lg tag, fine, pass thru (untainted)
+ # if it's a locale ID, try converting to a lg tag (untainted),
+ # otherwise nix it.
+
+ split m/[,:]/,
+ $ENV{$envname}
+ ;
+ last; # first one wins
+ }
+
+ if($ENV{'IGNORE_WIN32_LOCALE'}) {
+ # no-op
+ } elsif(&_try_use('Win32::Locale')) {
+ # If we have that module installed...
+ push @languages, Win32::Locale::get_language() || ''
+ if defined &Win32::Locale::get_language;
+ }
+ return _normalize @languages;
+}
+
+#---------------------------------------------------------------------------
+
+sub http_accept_langs {
+ # Deal with HTTP "Accept-Language:" stuff. Hassle.
+ # This code is more lenient than RFC 3282, which you must read.
+ # Hm. Should I just move this into I18N::LangTags at some point?
+ no integer;
+
+ my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
+ # (always ends up untainting)
+
+ return() unless defined $in and length $in;
+
+ $in =~ s/\([^\)]*\)//g; # nix just about any comment
+
+ if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
+ # Very common case: just one language tag
+ return _normalize $1;
+ } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
+ # Common case these days: just "foo, bar, baz"
+ return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
+ }
+
+ # Else it's complicated...
+
+ $in =~ s/\s+//g; # Yes, we can just do without the WS!
+ my @in = $in =~ m/([^,]+)/g;
+ my %pref;
+
+ my $q;
+ foreach my $tag (@in) {
+ next unless $tag =~
+ m/^([a-zA-Z][-a-zA-Z]+)
+ (?:
+ ;q=
+ (
+ \d* # a bit too broad of a RE, but so what.
+ (?:
+ \.\d+
+ )?
+ )
+ )?
+ $
+ /sx
+ ;
+ $q = (defined $2 and length $2) ? $2 : 1;
+ #print "$1 with q=$q\n";
+ push @{ $pref{$q} }, lc $1;
+ }
+
+ return _normalize(
+ # Read off %pref, in descending key order...
+ map @{$pref{$_}},
+ sort {$b <=> $a}
+ keys %pref
+ );
+}
+
+#===========================================================================
+
+my %tried = ();
+ # memoization of whether we've used this module, or found it unusable.
+
+sub _try_use { # Basically a wrapper around "require Modulename"
+ # "Many men have tried..." "They tried and failed?" "They tried and died."
+ return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
+
+ my $module = $_[0]; # ASSUME sane module name!
+ { no strict 'refs';
+ return($tried{$module} = 1)
+ if %{$module . "::Lexicon"} or @{$module . "::ISA"};
+ # weird case: we never use'd it, but there it is!
+ }
+
+ print " About to use $module ...\n" if DEBUG;
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
+ if($@) {
+ print "Error using $module \: $@\n" if DEBUG > 1;
+ return $tried{$module} = 0;
+ } else {
+ print " OK, $module is used\n" if DEBUG;
+ return $tried{$module} = 1;
+ }
+}
+
+#---------------------------------------------------------------------------
+1;
+__END__
+
+
+=head1 NAME
+
+I18N::LangTags::Detect - detect the user's language preferences
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags::Detect;
+ my @user_wants = I18N::LangTags::Detect::detect();
+
+=head1 DESCRIPTION
+
+It is a common problem to want to detect what language(s) the user would
+prefer output in.
+
+=head1 FUNCTIONS
+
+This module defines one public function,
+C<I18N::LangTags::Detect::detect()>. This function is not exported
+(nor is even exportable), and it takes no parameters.
+
+In scalar context, the function returns the most preferred language
+tag (or undef if no preference was seen).
+
+In list context (which is usually what you want),
+the function returns a
+(possibly empty) list of language tags representing (best first) what
+languages the user apparently would accept output in. You will
+probably want to pass the output of this through
+C<I18N::LangTags::implicate_supers_tightly(...)>
+or
+C<I18N::LangTags::implicate_supers(...)>, like so:
+
+ my @languages =
+ I18N::LangTags::implicate_supers_tightly(
+ I18N::LangTags::Detect::detect()
+ );
+
+
+=head1 ENVIRONMENT
+
+This module looks for several environment variables, including
+REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
+LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
+
+It will also use the L<Win32::Locale> module, if it's installed.
+
+
+=head1 SEE ALSO
+
+L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
+
+(This module's core code started out as a routine in Locale::Maketext;
+but I moved it here once I realized it was more generally useful.)
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998-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.
+
+The programs and documentation in this dist are distributed in
+the hope that they will be useful, but without any warranty; without
+even the implied warranty of merchantability or fitness for a
+particular purpose.
+
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
+# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!
diff --git a/Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm b/Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm
new file mode 100644
index 00000000000..5494bea21ed
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm
@@ -0,0 +1,1779 @@
+
+require 5;
+package I18N::LangTags::List;
+# Time-stamp: "2004-10-06 23:26:21 ADT"
+use strict;
+use vars qw(%Name %Is_Disrec $Debug $VERSION);
+$VERSION = '0.35';
+# POD at the end.
+
+#----------------------------------------------------------------------
+{
+# read the table out of our own POD!
+ my $seeking = 1;
+ my $count = 0;
+ my($disrec,$tag,$name);
+ my $last_name = '';
+ while(<I18N::LangTags::List::DATA>) {
+ if($seeking) {
+ $seeking = 0 if m/=for woohah/;
+ } elsif( ($disrec, $tag, $name) =
+ m/(\[?)\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/
+ ) {
+ $name =~ s/\s*[;\.]*\s*$//g;
+ next unless $name;
+ ++$count;
+ print "<$tag> <$name>\n" if $Debug;
+ $last_name = $Name{$tag} = $name;
+ $Is_Disrec{$tag} = 1 if $disrec;
+ } elsif (m/[Ff]ormerly \"([-a-z0-9]+)\"/) {
+ $Name{$1} = "$last_name (old tag)" if $last_name;
+ $Is_Disrec{$1} = 1;
+ }
+ }
+ die "No tags read??" unless $count;
+}
+#----------------------------------------------------------------------
+
+sub name {
+ my $tag = lc($_[0] || return);
+ $tag =~ s/^\s+//s;
+ $tag =~ s/\s+$//s;
+
+ my $alt;
+ if($tag =~ m/^x-(.+)/) {
+ $alt = "i-$1";
+ } elsif($tag =~ m/^i-(.+)/) {
+ $alt = "x-$1";
+ } else {
+ $alt = '';
+ }
+
+ my $subform = '';
+ my $name = '';
+ print "Input: {$tag}\n" if $Debug;
+ while(length $tag) {
+ last if $name = $Name{$tag};
+ last if $name = $Name{$alt};
+ if($tag =~ s/(-[a-z0-9]+)$//s) {
+ print "Shaving off: $1 leaving $tag\n" if $Debug;
+ $subform = "$1$subform";
+ # and loop around again
+
+ $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n";
+ } else {
+ # we're trying to pull a subform off a primary tag. TILT!
+ print "Aborting on: {$name}{$subform}\n" if $Debug;
+ last;
+ }
+ }
+ print "Output: {$name}{$subform}\n" if $Debug;
+
+ return unless $name; # Failure
+ return $name unless $subform; # Exact match
+ $subform =~ s/^-//s;
+ $subform =~ s/-$//s;
+ return "$name (Subform \"$subform\")";
+}
+
+#--------------------------------------------------------------------------
+
+sub is_decent {
+ my $tag = lc($_[0] || return 0);
+ #require I18N::LangTags;
+
+ return 0 unless
+ $tag =~
+ /^(?: # First subtag
+ [xi] | [a-z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-z0-9]{1,8} # subtag
+ )*
+ $/xs;
+
+ my @supers = ();
+ foreach my $bit (split('-', $tag)) {
+ push @supers,
+ scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
+ }
+ return 0 unless @supers;
+ shift @supers if $supers[0] =~ m<^(i|x|sgn)$>s;
+ return 0 unless @supers;
+
+ foreach my $f ($tag, @supers) {
+ return 0 if $Is_Disrec{$f};
+ return 2 if $Name{$f};
+ # so that decent subforms of indecent tags are decent
+ }
+ return 2 if $Name{$tag}; # not only is it decent, it's known!
+ return 1;
+}
+
+#--------------------------------------------------------------------------
+1;
+
+__DATA__
+
+=head1 NAME
+
+I18N::LangTags::List -- tags and names for human languages
+
+=head1 SYNOPSIS
+
+ use I18N::LangTags::List;
+ print "Parlez-vous... ", join(', ',
+ I18N::LangTags::List::name('elx') || 'unknown_language',
+ I18N::LangTags::List::name('ar-Kw') || 'unknown_language',
+ I18N::LangTags::List::name('en') || 'unknown_language',
+ I18N::LangTags::List::name('en-CA') || 'unknown_language',
+ ), "?\n";
+
+prints:
+
+ Parlez-vous... Elamite, Kuwait Arabic, English, Canadian English?
+
+=head1 DESCRIPTION
+
+This module provides a function
+C<I18N::LangTags::List::name( I<langtag> ) > that takes
+a language tag (see L<I18N::LangTags|I18N::LangTags>)
+and returns the best attempt at an English name for it, or
+undef if it can't make sense of the tag.
+
+The function I18N::LangTags::List::name(...) is not exported.
+
+This module also provides a function
+C<I18N::LangTags::List::is_decent( I<langtag> )> that returns true iff
+the language tag is syntactically valid and is for general use (like
+"fr" or "fr-ca", below). That is, it returns false for tags that are
+syntactically invalid and for tags, like "aus", that are listed in
+brackets below. This function is not exported.
+
+The map of tags-to-names that it uses is accessible as
+%I18N::LangTags::List::Name, and it's the same as the list
+that follows in this documentation, which should be useful
+to you even if you don't use this module.
+
+=head1 ABOUT LANGUAGE TAGS
+
+Internet language tags, as defined in RFC 3066, are a formalism
+for denoting human languages. The two-letter ISO 639-1 language
+codes are well known (as "en" for English), as are their forms
+when qualified by a country code ("en-US"). Less well-known are the
+arbitrary-length non-ISO codes (like "i-mingo"), and the
+recently (in 2001) introduced three-letter ISO-639-2 codes.
+
+Remember these important facts:
+
+=over
+
+=item *
+
+Language tags are not locale IDs. A locale ID is written with a "_"
+instead of a "-", (almost?) always matches C<m/^\w\w_\w\w\b/>, and
+I<means> something different than a language tag. A language tag
+denotes a language. A locale ID denotes a language I<as used in>
+a particular place, in combination with non-linguistic
+location-specific information such as what currency is used
+there. Locales I<also> often denote character set information,
+as in "en_US.ISO8859-1".
+
+=item *
+
+Language tags are not for computer languages.
+
+=item *
+
+"Dialect" is not a useful term, since there is no objective
+criterion for establishing when two language-forms are
+dialects of eachother, or are separate languages.
+
+=item *
+
+Language tags are not case-sensitive. en-US, en-us, En-Us, etc.,
+are all the same tag, and denote the same language.
+
+=item *
+
+Not every language tag really refers to a single language. Some
+language tags refer to conditions: i-default (system-message text
+in English plus maybe other languages), und (undetermined
+language). Others (notably lots of the three-letter codes) are
+bibliographic tags that classify whole groups of languages, as
+with cus "Cushitic (Other)" (i.e., a
+language that has been classed as Cushtic, but which has no more
+specific code) or the even less linguistically coherent
+sai for "South American Indian (Other)". Though useful in
+bibliography, B<SUCH TAGS ARE NOT
+FOR GENERAL USE>. For further guidance, email me.
+
+=item *
+
+Language tags are not country codes. In fact, they are often
+distinct codes, as with language tag ja for Japanese, and
+ISO 3166 country code C<.jp> for Japan.
+
+=back
+
+=head1 LIST OF LANGUAGES
+
+The first part of each item is the language tag, between
+{...}. It
+is followed by an English name for the language or language-group.
+Language tags that I judge to be not for general use, are bracketed.
+
+This list is in alphabetical order by English name of the language.
+
+=for reminder
+ The name in the =item line MUST NOT have E<...>'s in it!!
+
+=for woohah START
+
+=over
+
+=item {ab} : Abkhazian
+
+eq Abkhaz
+
+=item {ace} : Achinese
+
+=item {ach} : Acoli
+
+=item {ada} : Adangme
+
+=item {ady} : Adyghe
+
+eq Adygei
+
+=item {aa} : Afar
+
+=item {afh} : Afrihili
+
+(Artificial)
+
+=item {af} : Afrikaans
+
+=item [{afa} : Afro-Asiatic (Other)]
+
+=item {ak} : Akan
+
+(Formerly "aka".)
+
+=item {akk} : Akkadian
+
+(Historical)
+
+=item {sq} : Albanian
+
+=item {ale} : Aleut
+
+=item [{alg} : Algonquian languages]
+
+NOT Algonquin!
+
+=item [{tut} : Altaic (Other)]
+
+=item {am} : Amharic
+
+NOT Aramaic!
+
+=item {i-ami} : Ami
+
+eq Amis. eq 'Amis. eq Pangca.
+
+=item [{apa} : Apache languages]
+
+=item {ar} : Arabic
+
+Many forms are mutually un-intelligible in spoken media.
+Notable forms:
+{ar-ae} UAE Arabic;
+{ar-bh} Bahrain Arabic;
+{ar-dz} Algerian Arabic;
+{ar-eg} Egyptian Arabic;
+{ar-iq} Iraqi Arabic;
+{ar-jo} Jordanian Arabic;
+{ar-kw} Kuwait Arabic;
+{ar-lb} Lebanese Arabic;
+{ar-ly} Libyan Arabic;
+{ar-ma} Moroccan Arabic;
+{ar-om} Omani Arabic;
+{ar-qa} Qatari Arabic;
+{ar-sa} Sauda Arabic;
+{ar-sy} Syrian Arabic;
+{ar-tn} Tunisian Arabic;
+{ar-ye} Yemen Arabic.
+
+=item {arc} : Aramaic
+
+NOT Amharic! NOT Samaritan Aramaic!
+
+=item {arp} : Arapaho
+
+=item {arn} : Araucanian
+
+=item {arw} : Arawak
+
+=item {hy} : Armenian
+
+=item {an} : Aragonese
+
+=item [{art} : Artificial (Other)]
+
+=item {ast} : Asturian
+
+eq Bable.
+
+=item {as} : Assamese
+
+=item [{ath} : Athapascan languages]
+
+eq Athabaskan. eq Athapaskan. eq Athabascan.
+
+=item [{aus} : Australian languages]
+
+=item [{map} : Austronesian (Other)]
+
+=item {av} : Avaric
+
+(Formerly "ava".)
+
+=item {ae} : Avestan
+
+eq Zend
+
+=item {awa} : Awadhi
+
+=item {ay} : Aymara
+
+=item {az} : Azerbaijani
+
+eq Azeri
+
+Notable forms:
+{az-Arab} Azerbaijani in Arabic script;
+{az-Cyrl} Azerbaijani in Cyrillic script;
+{az-Latn} Azerbaijani in Latin script.
+
+=item {ban} : Balinese
+
+=item [{bat} : Baltic (Other)]
+
+=item {bal} : Baluchi
+
+=item {bm} : Bambara
+
+(Formerly "bam".)
+
+=item [{bai} : Bamileke languages]
+
+=item {bad} : Banda
+
+=item [{bnt} : Bantu (Other)]
+
+=item {bas} : Basa
+
+=item {ba} : Bashkir
+
+=item {eu} : Basque
+
+=item {btk} : Batak (Indonesia)
+
+=item {bej} : Beja
+
+=item {be} : Belarusian
+
+eq Belarussian. eq Byelarussian.
+eq Belorussian. eq Byelorussian.
+eq White Russian. eq White Ruthenian.
+NOT Ruthenian!
+
+=item {bem} : Bemba
+
+=item {bn} : Bengali
+
+eq Bangla.
+
+=item [{ber} : Berber (Other)]
+
+=item {bho} : Bhojpuri
+
+=item {bh} : Bihari
+
+=item {bik} : Bikol
+
+=item {bin} : Bini
+
+=item {bi} : Bislama
+
+eq Bichelamar.
+
+=item {bs} : Bosnian
+
+=item {bra} : Braj
+
+=item {br} : Breton
+
+=item {bug} : Buginese
+
+=item {bg} : Bulgarian
+
+=item {i-bnn} : Bunun
+
+=item {bua} : Buriat
+
+=item {my} : Burmese
+
+=item {cad} : Caddo
+
+=item {car} : Carib
+
+=item {ca} : Catalan
+
+eq CatalE<aacute>n. eq Catalonian.
+
+=item [{cau} : Caucasian (Other)]
+
+=item {ceb} : Cebuano
+
+=item [{cel} : Celtic (Other)]
+
+Notable forms:
+{cel-gaulish} Gaulish (Historical)
+
+=item [{cai} : Central American Indian (Other)]
+
+=item {chg} : Chagatai
+
+(Historical?)
+
+=item [{cmc} : Chamic languages]
+
+=item {ch} : Chamorro
+
+=item {ce} : Chechen
+
+=item {chr} : Cherokee
+
+eq Tsalagi
+
+=item {chy} : Cheyenne
+
+=item {chb} : Chibcha
+
+(Historical) NOT Chibchan (which is a language family).
+
+=item {ny} : Chichewa
+
+eq Nyanja. eq Chinyanja.
+
+=item {zh} : Chinese
+
+Many forms are mutually un-intelligible in spoken media.
+Notable forms:
+{zh-Hans} Chinese, in simplified script;
+{zh-Hant} Chinese, in traditional script;
+{zh-tw} Taiwan Chinese;
+{zh-cn} PRC Chinese;
+{zh-sg} Singapore Chinese;
+{zh-mo} Macau Chinese;
+{zh-hk} Hong Kong Chinese;
+{zh-guoyu} Mandarin [Putonghua/Guoyu];
+{zh-hakka} Hakka [formerly "i-hakka"];
+{zh-min} Hokkien;
+{zh-min-nan} Southern Hokkien;
+{zh-wuu} Shanghaiese;
+{zh-xiang} Hunanese;
+{zh-gan} Gan;
+{zh-yue} Cantonese.
+
+=for etc
+{i-hakka} Hakka (old tag)
+
+=item {chn} : Chinook Jargon
+
+eq Chinook Wawa.
+
+=item {chp} : Chipewyan
+
+=item {cho} : Choctaw
+
+=item {cu} : Church Slavic
+
+eq Old Church Slavonic.
+
+=item {chk} : Chuukese
+
+eq Trukese. eq Chuuk. eq Truk. eq Ruk.
+
+=item {cv} : Chuvash
+
+=item {cop} : Coptic
+
+=item {kw} : Cornish
+
+=item {co} : Corsican
+
+eq Corse.
+
+=item {cr} : Cree
+
+NOT Creek! (Formerly "cre".)
+
+=item {mus} : Creek
+
+NOT Cree!
+
+=item [{cpe} : English-based Creoles and pidgins (Other)]
+
+=item [{cpf} : French-based Creoles and pidgins (Other)]
+
+=item [{cpp} : Portuguese-based Creoles and pidgins (Other)]
+
+=item [{crp} : Creoles and pidgins (Other)]
+
+=item {hr} : Croatian
+
+eq Croat.
+
+=item [{cus} : Cushitic (Other)]
+
+=item {cs} : Czech
+
+=item {dak} : Dakota
+
+eq Nakota. eq Latoka.
+
+=item {da} : Danish
+
+=item {dar} : Dargwa
+
+=item {day} : Dayak
+
+=item {i-default} : Default (Fallthru) Language
+
+Defined in RFC 2277, this is for tagging text
+(which must include English text, and might/should include text
+in other appropriate languages) that is emitted in a context
+where language-negotiation wasn't possible -- in SMTP mail failure
+messages, for example.
+
+=item {del} : Delaware
+
+=item {din} : Dinka
+
+=item {dv} : Divehi
+
+eq Maldivian. (Formerly "div".)
+
+=item {doi} : Dogri
+
+NOT Dogrib!
+
+=item {dgr} : Dogrib
+
+NOT Dogri!
+
+=item [{dra} : Dravidian (Other)]
+
+=item {dua} : Duala
+
+=item {nl} : Dutch
+
+eq Netherlander. Notable forms:
+{nl-nl} Netherlands Dutch;
+{nl-be} Belgian Dutch.
+
+=item {dum} : Middle Dutch (ca.1050-1350)
+
+(Historical)
+
+=item {dyu} : Dyula
+
+=item {dz} : Dzongkha
+
+=item {efi} : Efik
+
+=item {egy} : Ancient Egyptian
+
+(Historical)
+
+=item {eka} : Ekajuk
+
+=item {elx} : Elamite
+
+(Historical)
+
+=item {en} : English
+
+Notable forms:
+{en-au} Australian English;
+{en-bz} Belize English;
+{en-ca} Canadian English;
+{en-gb} UK English;
+{en-ie} Irish English;
+{en-jm} Jamaican English;
+{en-nz} New Zealand English;
+{en-ph} Philippine English;
+{en-tt} Trinidad English;
+{en-us} US English;
+{en-za} South African English;
+{en-zw} Zimbabwe English.
+
+=item {enm} : Old English (1100-1500)
+
+(Historical)
+
+=item {ang} : Old English (ca.450-1100)
+
+eq Anglo-Saxon. (Historical)
+
+=item {i-enochian} : Enochian (Artificial)
+
+=item {myv} : Erzya
+
+=item {eo} : Esperanto
+
+(Artificial)
+
+=item {et} : Estonian
+
+=item {ee} : Ewe
+
+(Formerly "ewe".)
+
+=item {ewo} : Ewondo
+
+=item {fan} : Fang
+
+=item {fat} : Fanti
+
+=item {fo} : Faroese
+
+=item {fj} : Fijian
+
+=item {fi} : Finnish
+
+=item [{fiu} : Finno-Ugrian (Other)]
+
+eq Finno-Ugric. NOT Ugaritic!
+
+=item {fon} : Fon
+
+=item {fr} : French
+
+Notable forms:
+{fr-fr} France French;
+{fr-be} Belgian French;
+{fr-ca} Canadian French;
+{fr-ch} Swiss French;
+{fr-lu} Luxembourg French;
+{fr-mc} Monaco French.
+
+=item {frm} : Middle French (ca.1400-1600)
+
+(Historical)
+
+=item {fro} : Old French (842-ca.1400)
+
+(Historical)
+
+=item {fy} : Frisian
+
+=item {fur} : Friulian
+
+=item {ff} : Fulah
+
+(Formerly "ful".)
+
+=item {gaa} : Ga
+
+=item {gd} : Scots Gaelic
+
+NOT Scots!
+
+=item {gl} : Gallegan
+
+eq Galician
+
+=item {lg} : Ganda
+
+(Formerly "lug".)
+
+=item {gay} : Gayo
+
+=item {gba} : Gbaya
+
+=item {gez} : Geez
+
+eq Ge'ez
+
+=item {ka} : Georgian
+
+=item {de} : German
+
+Notable forms:
+{de-at} Austrian German;
+{de-be} Belgian German;
+{de-ch} Swiss German;
+{de-de} Germany German;
+{de-li} Liechtenstein German;
+{de-lu} Luxembourg German.
+
+=item {gmh} : Middle High German (ca.1050-1500)
+
+(Historical)
+
+=item {goh} : Old High German (ca.750-1050)
+
+(Historical)
+
+=item [{gem} : Germanic (Other)]
+
+=item {gil} : Gilbertese
+
+=item {gon} : Gondi
+
+=item {gor} : Gorontalo
+
+=item {got} : Gothic
+
+(Historical)
+
+=item {grb} : Grebo
+
+=item {grc} : Ancient Greek
+
+(Historical) (Until 15th century or so.)
+
+=item {el} : Modern Greek
+
+(Since 15th century or so.)
+
+=item {gn} : Guarani
+
+GuaranE<iacute>
+
+=item {gu} : Gujarati
+
+=item {gwi} : Gwich'in
+
+eq Gwichin
+
+=item {hai} : Haida
+
+=item {ht} : Haitian
+
+eq Haitian Creole
+
+=item {ha} : Hausa
+
+=item {haw} : Hawaiian
+
+Hawai'ian
+
+=item {he} : Hebrew
+
+(Formerly "iw".)
+
+=for etc
+{iw} Hebrew (old tag)
+
+=item {hz} : Herero
+
+=item {hil} : Hiligaynon
+
+=item {him} : Himachali
+
+=item {hi} : Hindi
+
+=item {ho} : Hiri Motu
+
+=item {hit} : Hittite
+
+(Historical)
+
+=item {hmn} : Hmong
+
+=item {hu} : Hungarian
+
+=item {hup} : Hupa
+
+=item {iba} : Iban
+
+=item {is} : Icelandic
+
+=item {io} : Ido
+
+(Artificial)
+
+=item {ig} : Igbo
+
+(Formerly "ibo".)
+
+=item {ijo} : Ijo
+
+=item {ilo} : Iloko
+
+=item [{inc} : Indic (Other)]
+
+=item [{ine} : Indo-European (Other)]
+
+=item {id} : Indonesian
+
+(Formerly "in".)
+
+=for etc
+{in} Indonesian (old tag)
+
+=item {inh} : Ingush
+
+=item {ia} : Interlingua (International Auxiliary Language Association)
+
+(Artificial) NOT Interlingue!
+
+=item {ie} : Interlingue
+
+(Artificial) NOT Interlingua!
+
+=item {iu} : Inuktitut
+
+A subform of "Eskimo".
+
+=item {ik} : Inupiaq
+
+A subform of "Eskimo".
+
+=item [{ira} : Iranian (Other)]
+
+=item {ga} : Irish
+
+=item {mga} : Middle Irish (900-1200)
+
+(Historical)
+
+=item {sga} : Old Irish (to 900)
+
+(Historical)
+
+=item [{iro} : Iroquoian languages]
+
+=item {it} : Italian
+
+Notable forms:
+{it-it} Italy Italian;
+{it-ch} Swiss Italian.
+
+=item {ja} : Japanese
+
+(NOT "jp"!)
+
+=item {jv} : Javanese
+
+(Formerly "jw" because of a typo.)
+
+=item {jrb} : Judeo-Arabic
+
+=item {jpr} : Judeo-Persian
+
+=item {kbd} : Kabardian
+
+=item {kab} : Kabyle
+
+=item {kac} : Kachin
+
+=item {kl} : Kalaallisut
+
+eq Greenlandic "Eskimo"
+
+=item {xal} : Kalmyk
+
+=item {kam} : Kamba
+
+=item {kn} : Kannada
+
+eq Kanarese. NOT Canadian!
+
+=item {kr} : Kanuri
+
+(Formerly "kau".)
+
+=item {krc} : Karachay-Balkar
+
+=item {kaa} : Kara-Kalpak
+
+=item {kar} : Karen
+
+=item {ks} : Kashmiri
+
+=item {csb} : Kashubian
+
+eq Kashub
+
+=item {kaw} : Kawi
+
+=item {kk} : Kazakh
+
+=item {kha} : Khasi
+
+=item {km} : Khmer
+
+eq Cambodian. eq Kampuchean.
+
+=item [{khi} : Khoisan (Other)]
+
+=item {kho} : Khotanese
+
+=item {ki} : Kikuyu
+
+eq Gikuyu.
+
+=item {kmb} : Kimbundu
+
+=item {rw} : Kinyarwanda
+
+=item {ky} : Kirghiz
+
+=item {i-klingon} : Klingon
+
+=item {kv} : Komi
+
+=item {kg} : Kongo
+
+(Formerly "kon".)
+
+=item {kok} : Konkani
+
+=item {ko} : Korean
+
+=item {kos} : Kosraean
+
+=item {kpe} : Kpelle
+
+=item {kro} : Kru
+
+=item {kj} : Kuanyama
+
+=item {kum} : Kumyk
+
+=item {ku} : Kurdish
+
+=item {kru} : Kurukh
+
+=item {kut} : Kutenai
+
+=item {lad} : Ladino
+
+eq Judeo-Spanish. NOT Ladin (a minority language in Italy).
+
+=item {lah} : Lahnda
+
+NOT Lamba!
+
+=item {lam} : Lamba
+
+NOT Lahnda!
+
+=item {lo} : Lao
+
+eq Laotian.
+
+=item {la} : Latin
+
+(Historical) NOT Ladin! NOT Ladino!
+
+=item {lv} : Latvian
+
+eq Lettish.
+
+=item {lb} : Letzeburgesch
+
+eq Luxemburgian, eq Luxemburger. (Formerly "i-lux".)
+
+=for etc
+{i-lux} Letzeburgesch (old tag)
+
+=item {lez} : Lezghian
+
+=item {li} : Limburgish
+
+eq Limburger, eq Limburgan. NOT Letzeburgesch!
+
+=item {ln} : Lingala
+
+=item {lt} : Lithuanian
+
+=item {nds} : Low German
+
+eq Low Saxon. eq Low German. eq Low Saxon.
+
+=item {art-lojban} : Lojban (Artificial)
+
+=item {loz} : Lozi
+
+=item {lu} : Luba-Katanga
+
+(Formerly "lub".)
+
+=item {lua} : Luba-Lulua
+
+=item {lui} : Luiseno
+
+eq LuiseE<ntilde>o.
+
+=item {lun} : Lunda
+
+=item {luo} : Luo (Kenya and Tanzania)
+
+=item {lus} : Lushai
+
+=item {mk} : Macedonian
+
+eq the modern Slavic language spoken in what was Yugoslavia.
+NOT the form of Greek spoken in Greek Macedonia!
+
+=item {mad} : Madurese
+
+=item {mag} : Magahi
+
+=item {mai} : Maithili
+
+=item {mak} : Makasar
+
+=item {mg} : Malagasy
+
+=item {ms} : Malay
+
+NOT Malayalam!
+
+=item {ml} : Malayalam
+
+NOT Malay!
+
+=item {mt} : Maltese
+
+=item {mnc} : Manchu
+
+=item {mdr} : Mandar
+
+NOT Mandarin!
+
+=item {man} : Mandingo
+
+=item {mni} : Manipuri
+
+eq Meithei.
+
+=item [{mno} : Manobo languages]
+
+=item {gv} : Manx
+
+=item {mi} : Maori
+
+NOT Mari!
+
+=item {mr} : Marathi
+
+=item {chm} : Mari
+
+NOT Maori!
+
+=item {mh} : Marshall
+
+eq Marshallese.
+
+=item {mwr} : Marwari
+
+=item {mas} : Masai
+
+=item [{myn} : Mayan languages]
+
+=item {men} : Mende
+
+=item {mic} : Micmac
+
+=item {min} : Minangkabau
+
+=item {i-mingo} : Mingo
+
+eq the Irquoian language West Virginia Seneca. NOT New York Seneca!
+
+=item [{mis} : Miscellaneous languages]
+
+Don't use this.
+
+=item {moh} : Mohawk
+
+=item {mdf} : Moksha
+
+=item {mo} : Moldavian
+
+eq Moldovan.
+
+=item [{mkh} : Mon-Khmer (Other)]
+
+=item {lol} : Mongo
+
+=item {mn} : Mongolian
+
+eq Mongol.
+
+=item {mos} : Mossi
+
+=item [{mul} : Multiple languages]
+
+Not for normal use.
+
+=item [{mun} : Munda languages]
+
+=item {nah} : Nahuatl
+
+=item {nap} : Neapolitan
+
+=item {na} : Nauru
+
+=item {nv} : Navajo
+
+eq Navaho. (Formerly "i-navajo".)
+
+=for etc
+{i-navajo} Navajo (old tag)
+
+=item {nd} : North Ndebele
+
+=item {nr} : South Ndebele
+
+=item {ng} : Ndonga
+
+=item {ne} : Nepali
+
+eq Nepalese. Notable forms:
+{ne-np} Nepal Nepali;
+{ne-in} India Nepali.
+
+=item {new} : Newari
+
+=item {nia} : Nias
+
+=item [{nic} : Niger-Kordofanian (Other)]
+
+=item [{ssa} : Nilo-Saharan (Other)]
+
+=item {niu} : Niuean
+
+=item {nog} : Nogai
+
+=item {non} : Old Norse
+
+(Historical)
+
+=item [{nai} : North American Indian]
+
+Do not use this.
+
+=item {no} : Norwegian
+
+Note the two following forms:
+
+=item {nb} : Norwegian Bokmal
+
+eq BokmE<aring>l, (A form of Norwegian.) (Formerly "no-bok".)
+
+=for etc
+{no-bok} Norwegian Bokmal (old tag)
+
+=item {nn} : Norwegian Nynorsk
+
+(A form of Norwegian.) (Formerly "no-nyn".)
+
+=for etc
+{no-nyn} Norwegian Nynorsk (old tag)
+
+=item [{nub} : Nubian languages]
+
+=item {nym} : Nyamwezi
+
+=item {nyn} : Nyankole
+
+=item {nyo} : Nyoro
+
+=item {nzi} : Nzima
+
+=item {oc} : Occitan (post 1500)
+
+eq ProvenE<ccedil>al, eq Provencal
+
+=item {oj} : Ojibwa
+
+eq Ojibwe. (Formerly "oji".)
+
+=item {or} : Oriya
+
+=item {om} : Oromo
+
+=item {osa} : Osage
+
+=item {os} : Ossetian; Ossetic
+
+=item [{oto} : Otomian languages]
+
+Group of languages collectively called "OtomE<iacute>".
+
+=item {pal} : Pahlavi
+
+eq Pahlevi
+
+=item {i-pwn} : Paiwan
+
+eq Pariwan
+
+=item {pau} : Palauan
+
+=item {pi} : Pali
+
+(Historical?)
+
+=item {pam} : Pampanga
+
+=item {pag} : Pangasinan
+
+=item {pa} : Panjabi
+
+eq Punjabi
+
+=item {pap} : Papiamento
+
+eq Papiamentu.
+
+=item [{paa} : Papuan (Other)]
+
+=item {fa} : Persian
+
+eq Farsi. eq Iranian.
+
+=item {peo} : Old Persian (ca.600-400 B.C.)
+
+=item [{phi} : Philippine (Other)]
+
+=item {phn} : Phoenician
+
+(Historical)
+
+=item {pon} : Pohnpeian
+
+NOT Pompeiian!
+
+=item {pl} : Polish
+
+=item {pt} : Portuguese
+
+eq Portugese. Notable forms:
+{pt-pt} Portugal Portuguese;
+{pt-br} Brazilian Portuguese.
+
+=item [{pra} : Prakrit languages]
+
+=item {pro} : Old Provencal (to 1500)
+
+eq Old ProvenE<ccedil>al. (Historical.)
+
+=item {ps} : Pushto
+
+eq Pashto. eq Pushtu.
+
+=item {qu} : Quechua
+
+eq Quecha.
+
+=item {rm} : Raeto-Romance
+
+eq Romansh.
+
+=item {raj} : Rajasthani
+
+=item {rap} : Rapanui
+
+=item {rar} : Rarotongan
+
+=item [{qaa - qtz} : Reserved for local use.]
+
+=item [{roa} : Romance (Other)]
+
+NOT Romanian! NOT Romany! NOT Romansh!
+
+=item {ro} : Romanian
+
+eq Rumanian. NOT Romany!
+
+=item {rom} : Romany
+
+eq Rom. NOT Romanian!
+
+=item {rn} : Rundi
+
+=item {ru} : Russian
+
+NOT White Russian! NOT Rusyn!
+
+=item [{sal} : Salishan languages]
+
+Large language group.
+
+=item {sam} : Samaritan Aramaic
+
+NOT Aramaic!
+
+=item {se} : Northern Sami
+
+eq Lappish. eq Lapp. eq (Northern) Saami.
+
+=item {sma} : Southern Sami
+
+=item {smn} : Inari Sami
+
+=item {smj} : Lule Sami
+
+=item {sms} : Skolt Sami
+
+=item [{smi} : Sami languages (Other)]
+
+=item {sm} : Samoan
+
+=item {sad} : Sandawe
+
+=item {sg} : Sango
+
+=item {sa} : Sanskrit
+
+(Historical)
+
+=item {sat} : Santali
+
+=item {sc} : Sardinian
+
+eq Sard.
+
+=item {sas} : Sasak
+
+=item {sco} : Scots
+
+NOT Scots Gaelic!
+
+=item {sel} : Selkup
+
+=item [{sem} : Semitic (Other)]
+
+=item {sr} : Serbian
+
+eq Serb. NOT Sorbian.
+
+Notable forms:
+{sr-Cyrl} : Serbian in Cyrillic script;
+{sr-Latn} : Serbian in Latin script.
+
+=item {srr} : Serer
+
+=item {shn} : Shan
+
+=item {sn} : Shona
+
+=item {sid} : Sidamo
+
+=item {sgn-...} : Sign Languages
+
+Always use with a subtag. Notable forms:
+{sgn-gb} British Sign Language (BSL);
+{sgn-ie} Irish Sign Language (ESL);
+{sgn-ni} Nicaraguan Sign Language (ISN);
+{sgn-us} American Sign Language (ASL).
+
+(And so on with other country codes as the subtag.)
+
+=item {bla} : Siksika
+
+eq Blackfoot. eq Pikanii.
+
+=item {sd} : Sindhi
+
+=item {si} : Sinhalese
+
+eq Sinhala.
+
+=item [{sit} : Sino-Tibetan (Other)]
+
+=item [{sio} : Siouan languages]
+
+=item {den} : Slave (Athapascan)
+
+("Slavey" is a subform.)
+
+=item [{sla} : Slavic (Other)]
+
+=item {sk} : Slovak
+
+eq Slovakian.
+
+=item {sl} : Slovenian
+
+eq Slovene.
+
+=item {sog} : Sogdian
+
+=item {so} : Somali
+
+=item {son} : Songhai
+
+=item {snk} : Soninke
+
+=item {wen} : Sorbian languages
+
+eq Wendish. eq Sorb. eq Lusatian. eq Wend. NOT Venda! NOT Serbian!
+
+=item {nso} : Northern Sotho
+
+=item {st} : Southern Sotho
+
+eq Sutu. eq Sesotho.
+
+=item [{sai} : South American Indian (Other)]
+
+=item {es} : Spanish
+
+Notable forms:
+{es-ar} Argentine Spanish;
+{es-bo} Bolivian Spanish;
+{es-cl} Chilean Spanish;
+{es-co} Colombian Spanish;
+{es-do} Dominican Spanish;
+{es-ec} Ecuadorian Spanish;
+{es-es} Spain Spanish;
+{es-gt} Guatemalan Spanish;
+{es-hn} Honduran Spanish;
+{es-mx} Mexican Spanish;
+{es-pa} Panamanian Spanish;
+{es-pe} Peruvian Spanish;
+{es-pr} Puerto Rican Spanish;
+{es-py} Paraguay Spanish;
+{es-sv} Salvadoran Spanish;
+{es-us} US Spanish;
+{es-uy} Uruguayan Spanish;
+{es-ve} Venezuelan Spanish.
+
+=item {suk} : Sukuma
+
+=item {sux} : Sumerian
+
+(Historical)
+
+=item {su} : Sundanese
+
+=item {sus} : Susu
+
+=item {sw} : Swahili
+
+eq Kiswahili
+
+=item {ss} : Swati
+
+=item {sv} : Swedish
+
+Notable forms:
+{sv-se} Sweden Swedish;
+{sv-fi} Finland Swedish.
+
+=item {syr} : Syriac
+
+=item {tl} : Tagalog
+
+=item {ty} : Tahitian
+
+=item [{tai} : Tai (Other)]
+
+NOT Thai!
+
+=item {tg} : Tajik
+
+=item {tmh} : Tamashek
+
+=item {ta} : Tamil
+
+=item {i-tao} : Tao
+
+eq Yami.
+
+=item {tt} : Tatar
+
+=item {i-tay} : Tayal
+
+eq Atayal. eq Atayan.
+
+=item {te} : Telugu
+
+=item {ter} : Tereno
+
+=item {tet} : Tetum
+
+=item {th} : Thai
+
+NOT Tai!
+
+=item {bo} : Tibetan
+
+=item {tig} : Tigre
+
+=item {ti} : Tigrinya
+
+=item {tem} : Timne
+
+eq Themne. eq Timene.
+
+=item {tiv} : Tiv
+
+=item {tli} : Tlingit
+
+=item {tpi} : Tok Pisin
+
+=item {tkl} : Tokelau
+
+=item {tog} : Tonga (Nyasa)
+
+NOT Tsonga!
+
+=item {to} : Tonga (Tonga Islands)
+
+(Pronounced "Tong-a", not "Tong-ga")
+
+NOT Tsonga!
+
+=item {tsi} : Tsimshian
+
+eq Sm'algyax
+
+=item {ts} : Tsonga
+
+NOT Tonga!
+
+=item {i-tsu} : Tsou
+
+=item {tn} : Tswana
+
+Same as Setswana.
+
+=item {tum} : Tumbuka
+
+=item [{tup} : Tupi languages]
+
+=item {tr} : Turkish
+
+(Typically in Roman script)
+
+=item {ota} : Ottoman Turkish (1500-1928)
+
+(Typically in Arabic script) (Historical)
+
+=item {crh} : Crimean Turkish
+
+eq Crimean Tatar
+
+=item {tk} : Turkmen
+
+eq Turkmeni.
+
+=item {tvl} : Tuvalu
+
+=item {tyv} : Tuvinian
+
+eq Tuvan. eq Tuvin.
+
+=item {tw} : Twi
+
+=item {udm} : Udmurt
+
+=item {uga} : Ugaritic
+
+NOT Ugric!
+
+=item {ug} : Uighur
+
+=item {uk} : Ukrainian
+
+=item {umb} : Umbundu
+
+=item {und} : Undetermined
+
+Not a tag for normal use.
+
+=item {ur} : Urdu
+
+=item {uz} : Uzbek
+
+eq E<Ouml>zbek
+
+Notable forms:
+{uz-Cyrl} Uzbek in Cyrillic script;
+{uz-Latn} Uzbek in Latin script.
+
+=item {vai} : Vai
+
+=item {ve} : Venda
+
+NOT Wendish! NOT Wend! NOT Avestan! (Formerly "ven".)
+
+=item {vi} : Vietnamese
+
+eq Viet.
+
+=item {vo} : Volapuk
+
+eq VolapE<uuml>k. (Artificial)
+
+=item {vot} : Votic
+
+eq Votian. eq Vod.
+
+=item [{wak} : Wakashan languages]
+
+=item {wa} : Walloon
+
+=item {wal} : Walamo
+
+eq Wolaytta.
+
+=item {war} : Waray
+
+Presumably the Philippine language Waray-Waray (SamareE<ntilde>o),
+not the smaller Philippine language Waray Sorsogon, nor the extinct
+Australian language Waray.
+
+=item {was} : Washo
+
+eq Washoe
+
+=item {cy} : Welsh
+
+=item {wo} : Wolof
+
+=item {x-...} : Unregistered (Semi-Private Use)
+
+"x-" is a prefix for language tags that are not registered with ISO
+or IANA. Example, x-double-dutch
+
+=item {xh} : Xhosa
+
+=item {sah} : Yakut
+
+=item {yao} : Yao
+
+(The Yao in Malawi?)
+
+=item {yap} : Yapese
+
+eq Yap
+
+=item {ii} : Sichuan Yi
+
+=item {yi} : Yiddish
+
+Formerly "ji". Usually in Hebrew script.
+
+Notable forms:
+{yi-latn} Yiddish in Latin script
+
+=item {yo} : Yoruba
+
+=item [{ypk} : Yupik languages]
+
+Several "Eskimo" languages.
+
+=item {znd} : Zande
+
+=item [{zap} : Zapotec]
+
+(A group of languages.)
+
+=item {zen} : Zenaga
+
+NOT Zend.
+
+=item {za} : Zhuang
+
+=item {zu} : Zulu
+
+=item {zun} : Zuni
+
+eq ZuE<ntilde>i
+
+=back
+
+=for woohah END
+
+=head1 SEE ALSO
+
+L<I18N::LangTags|I18N::LangTags> and its "See Also" section.
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+Copyright (c) 2001+ Sean M. Burke. All rights reserved.
+
+You can redistribute and/or
+modify this document under the same terms as Perl itself.
+
+This document is provided in the hope that it will be
+useful, but without any warranty;
+without even the implied warranty of accuracy, authoritativeness,
+completeness, merchantability, or fitness for a particular purpose.
+
+Email any corrections or questions to me.
+
+=head1 AUTHOR
+
+Sean M. Burke, sburkeE<64>cpan.org
+
+=cut
+
+
+# To generate a list of just the two and three-letter codes:
+
+#!/usr/local/bin/perl -w
+
+require 5; # Time-stamp: "2001-03-13 21:53:39 MST"
+ # Sean M. Burke, sburke@cpan.org
+ # This program is for generating the language_codes.txt file
+use strict;
+use LWP::Simple;
+use HTML::TreeBuilder 3.10;
+my $root = HTML::TreeBuilder->new();
+my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html';
+$root->parse(get($url) || die "Can't get $url");
+$root->eof();
+
+my @codes;
+
+foreach my $tr ($root->find_by_tag_name('tr')) {
+ my @f = map $_->as_text(), $tr->content_list();
+ #print map("<$_> ", @f), "\n";
+ next unless @f == 5;
+ pop @f; # nix the French name
+ next if $f[-1] eq 'Language Name (English)'; # it's a header line
+ my $xx = splice(@f, 2,1); # pull out the two-letter code
+ $f[-1] =~ s/^\s+//;
+ $f[-1] =~ s/\s+$//;
+ if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it
+ push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ];
+ } else { # print the three-letter codes.
+ if($f[0] eq $f[1]) {
+ push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ];
+ } else { # shouldn't happen
+ push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ];
+ }
+ }
+}
+
+print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes;
+print "[ based on $url\n at ", scalar(localtime), "]\n",
+ "[Note: doesn't include IANA-registered codes.]\n";
+exit;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm
new file mode 100644
index 00000000000..e60c93fda24
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm
@@ -0,0 +1,1646 @@
+package IPC::Cmd;
+
+use strict;
+
+BEGIN {
+
+ use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
+ use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+ use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
+ use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut';
+ use constant SPECIAL_CHARS => qw[< > | &];
+ use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
+
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
+ $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
+ ];
+
+ $VERSION = '0.54';
+ $VERBOSE = 0;
+ $DEBUG = 0;
+ $WARN = 1;
+ $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
+ $USE_IPC_OPEN3 = not IS_VMS;
+
+ $CAN_USE_RUN_FORKED = 0;
+ eval {
+ require POSIX; POSIX->import();
+ require IPC::Open3; IPC::Open3->import();
+ require IO::Select; IO::Select->import();
+ require IO::Handle; IO::Handle->import();
+ require FileHandle; FileHandle->import();
+ require Socket; Socket->import();
+ require Time::HiRes; Time::HiRes->import();
+ };
+ $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
+
+ @ISA = qw[Exporter];
+ @EXPORT_OK = qw[can_run run run_forked QUOTE];
+}
+
+require Carp;
+use File::Spec;
+use Params::Check qw[check];
+use Text::ParseWords (); # import ONLY if needed!
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Style => 'gettext';
+
+=pod
+
+=head1 NAME
+
+IPC::Cmd - finding and running system commands made easy
+
+=head1 SYNOPSIS
+
+ use IPC::Cmd qw[can_run run run_forked];
+
+ my $full_path = can_run('wget') or warn 'wget is not installed!';
+
+ ### commands can be arrayrefs or strings ###
+ my $cmd = "$full_path -b theregister.co.uk";
+ my $cmd = [$full_path, '-b', 'theregister.co.uk'];
+
+ ### in scalar context ###
+ my $buffer;
+ if( scalar run( command => $cmd,
+ verbose => 0,
+ buffer => \$buffer,
+ timeout => 20 )
+ ) {
+ print "fetched webpage successfully: $buffer\n";
+ }
+
+
+ ### in list context ###
+ my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+ run( command => $cmd, verbose => 0 );
+
+ if( $success ) {
+ print "this is what the command printed:\n";
+ print join "", @$full_buf;
+ }
+
+ ### check for features
+ print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
+ print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
+ print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
+
+ ### don't have IPC::Cmd be verbose, ie don't print to stdout or
+ ### stderr when running commands -- default is '0'
+ $IPC::Cmd::VERBOSE = 0;
+
+
+=head1 DESCRIPTION
+
+IPC::Cmd allows you to run commands, interactively if desired,
+platform independent but have them still work.
+
+The C<can_run> function can tell you if a certain binary is installed
+and if so where, whereas the C<run> function can actually execute any
+of the commands you give it and give you a clear return value, as well
+as adhere to your verbosity settings.
+
+=head1 CLASS METHODS
+
+=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Run> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Run> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_run {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::run doesn't run on win98
+ return if IS_WIN98;
+
+ ### if we dont have ipc::run, we obviously can't use it.
+ return unless can_load(
+ modules => { 'IPC::Run' => '0.55' },
+ verbose => ($WARN && $verbose),
+ );
+
+ ### otherwise, we're good to go
+ return $IPC::Run::VERSION;
+}
+
+=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Open3> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Open3> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_open3 {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::open3 is not working on VMS becasue of a lack of fork.
+ ### XXX todo, win32 also does not have fork, so need to do more research.
+ return if IS_VMS;
+
+ ### ipc::open3 works on every non-VMS platform platform, but it can't
+ ### capture buffers on win32 :(
+ return unless can_load(
+ modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
+ verbose => ($WARN && $verbose),
+ );
+
+ return $IPC::Open3::VERSION;
+}
+
+=head2 $bool = IPC::Cmd->can_capture_buffer
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+capturing buffers in it's current configuration.
+
+=cut
+
+sub can_capture_buffer {
+ my $self = shift;
+
+ return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
+ return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3 && !IS_WIN32;
+ return;
+}
+
+=head2 $bool = IPC::Cmd->can_use_run_forked
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+providing C<run_forked> on the current platform.
+
+=head1 FUNCTIONS
+
+=head2 $path = can_run( PROGRAM );
+
+C<can_run> takes but a single argument: the name of a binary you wish
+to locate. C<can_run> works much like the unix binary C<which> or the bash
+command C<type>, which scans through your path, looking for the requested
+binary .
+
+Unlike C<which> and C<type>, this function is platform independent and
+will also work on, for example, Win32.
+
+It will return the full path to the binary you asked for if it was
+found, or C<undef> if it was not.
+
+=cut
+
+sub can_run {
+ my $command = shift;
+
+ # a lot of VMS executables have a symbol defined
+ # check those first
+ if ( $^O eq 'VMS' ) {
+ require VMS::DCLsym;
+ my $syms = VMS::DCLsym->new;
+ return $command if scalar $syms->getsym( uc $command );
+ }
+
+ require Config;
+ require File::Spec;
+ require ExtUtils::MakeMaker;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return MM->maybe_command($command);
+
+ } else {
+ for my $dir (
+ (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
+ File::Spec->curdir
+ ) {
+ my $abs = File::Spec->catfile($dir, $command);
+ return $abs if $abs = MM->maybe_command($abs);
+ }
+ }
+}
+
+=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
+
+C<run> takes 4 arguments:
+
+=over 4
+
+=item command
+
+This is the command to execute. It may be either a string or an array
+reference.
+This is a required argument.
+
+See L<CAVEATS> for remarks on how commands are parsed and their
+limitations.
+
+=item verbose
+
+This controls whether all output of a command should also be printed
+to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
+require C<IPC::Run> to be installed or your system able to work with
+C<IPC::Open3>).
+
+It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
+which by default is 0.
+
+=item buffer
+
+This will hold all the output of a command. It needs to be a reference
+to a scalar.
+Note that this will hold both the STDOUT and STDERR messages, and you
+have no way of telling which is which.
+If you require this distinction, run the C<run> command in list context
+and inspect the individual buffers.
+
+Of course, this requires that the underlying call supports buffers. See
+the note on buffers right above.
+
+=item timeout
+
+Sets the maximum time the command is allowed to run before aborting,
+using the built-in C<alarm()> call. If the timeout is triggered, the
+C<errorcode> in the return value will be set to an object of the
+C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
+details.
+
+Defaults to C<0>, meaning no timeout is set.
+
+=back
+
+C<run> will return a simple C<true> or C<false> when called in scalar
+context.
+In list context, you will be returned a list of the following items:
+
+=over 4
+
+=item success
+
+A simple boolean indicating if the command executed without errors or
+not.
+
+=item error message
+
+If the first element of the return value (success) was 0, then some
+error occurred. This second element is the error message the command
+you requested exited with, if available. This is generally a pretty
+printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
+what they can contain.
+If the error was a timeout, the C<error message> will be prefixed with
+the string C<IPC::Cmd::TimeOut>, the timeout class.
+
+=item full_buffer
+
+This is an arrayreference containing all the output the command
+generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item out_buffer
+
+This is an arrayreference containing all the output sent to STDOUT the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item error_buffer
+
+This is an arrayreference containing all the output sent to STDERR the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=back
+
+See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
+what modules or function calls to use when issuing a command.
+
+=cut
+
+{ my @acc = qw[ok error _fds];
+
+ ### autogenerate accessors ###
+ for my $key ( @acc ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+ }
+}
+
+sub can_use_run_forked {
+ return $CAN_USE_RUN_FORKED eq "1";
+}
+
+# give process a chance sending TERM,
+# waiting for a while (2 seconds)
+# and killing it with KILL
+sub kill_gently {
+ my ($pid) = @_;
+
+ kill(15, $pid);
+
+ my $wait_cycles = 0;
+ my $child_finished = 0;
+
+ while (!$child_finished && $wait_cycles < 8) {
+ my $waitpid = waitpid($pid, WNOHANG);
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ }
+
+ $wait_cycles = $wait_cycles + 1;
+ Time::HiRes::usleep(250000); # half a second
+ }
+}
+
+sub open3_run {
+ my ($cmd, $opts) = @_;
+
+ $opts = {} unless $opts;
+
+ my $child_in = FileHandle->new;
+ my $child_out = FileHandle->new;
+ my $child_err = FileHandle->new;
+ $child_out->autoflush(1);
+ $child_err->autoflush(1);
+
+ my $pid = open3($child_in, $child_out, $child_err, $cmd);
+
+ # push my child's pid to our parent
+ # so in case i am killed parent
+ # could stop my child (search for
+ # child_child_pid in parent code)
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "spawned $pid\n";
+ }
+
+ if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
+
+ # If the child process dies for any reason,
+ # the next write to CHLD_IN is likely to generate
+ # a SIGPIPE in the parent, which is fatal by default.
+ # So you may wish to handle this signal.
+ #
+ # from http://perldoc.perl.org/IPC/Open3.html,
+ # absolutely needed to catch piped commands errors.
+ #
+ local $SIG{'SIG_PIPE'} = sub { 1; };
+
+ print $child_in $opts->{'child_stdin'};
+ }
+ close($child_in);
+
+ my $child_output = {
+ 'out' => $child_out->fileno,
+ 'err' => $child_err->fileno,
+ $child_out->fileno => {
+ 'parent_socket' => $opts->{'parent_stdout'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_out,
+ 'block_size' => ($child_out->stat)[11] || 1024,
+ },
+ $child_err->fileno => {
+ 'parent_socket' => $opts->{'parent_stderr'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_err,
+ 'block_size' => ($child_err->stat)[11] || 1024,
+ },
+ };
+
+ my $select = IO::Select->new();
+ $select->add($child_out, $child_err);
+
+ # pass any signal to the child
+ # effectively creating process
+ # strongly attached to the child:
+ # it will terminate only after child
+ # has terminated (except for SIGKILL,
+ # which is specially handled)
+ foreach my $s (keys %SIG) {
+ my $sig_handler;
+ $sig_handler = sub {
+ kill("$s", $pid);
+ $SIG{$s} = $sig_handler;
+ };
+ $SIG{$s} = $sig_handler;
+ }
+
+ my $child_finished = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ while(!$child_finished && ($child_out->opened || $child_err->opened)) {
+
+ # parent was killed otherwise we would have got
+ # the same signal as parent and process it same way
+ if (getppid() eq "1") {
+ kill_gently($pid);
+ exit;
+ }
+
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ Time::HiRes::usleep(1);
+
+ foreach my $fd ($select->can_read(1/100)) {
+ my $str = $child_output->{$fd->fileno};
+ psSnake::die("child stream not found: $fd") unless $str;
+
+ my $data;
+ my $count = $fd->sysread($data, $str->{'block_size'});
+
+ if ($count) {
+ if ($str->{'parent_socket'}) {
+ my $ph = $str->{'parent_socket'};
+ print $ph $data;
+ }
+ else {
+ $str->{'scalar_buffer'} .= $data;
+ }
+ }
+ elsif ($count eq 0) {
+ $select->remove($fd);
+ $fd->close();
+ }
+ else {
+ psSnake::die("error during sysread: " . $!);
+ }
+ }
+ }
+
+ waitpid($pid, 0);
+
+ # i've successfully reaped my child,
+ # let my parent know this
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "reaped $pid\n";
+ }
+
+ my $real_exit = $?;
+ my $exit_value = $real_exit >> 8;
+ if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
+ return $exit_value;
+ }
+ else {
+ return {
+ 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
+ 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
+ 'exit_code' => $exit_value,
+ };
+ }
+}
+
+=head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
+
+C<run_forked> is used to execute some program,
+optionally feed it with some input, get its return code
+and output (both stdout and stderr into seperate buffers).
+In addition it allows to terminate the program
+which take too long to finish.
+
+The important and distinguishing feature of run_forked
+is execution timeout which at first seems to be
+quite a simple task but if you think
+that the program which you're spawning
+might spawn some children itself (which
+in their turn could do the same and so on)
+it turns out to be not a simple issue.
+
+C<run_forked> is designed to survive and
+successfully terminate almost any long running task,
+even a fork bomb in case your system has the resources
+to survive during given timeout.
+
+This is achieved by creating separate watchdog process
+which spawns the specified program in a separate
+process session and supervises it: optionally
+feeds it with input, stores its exit code,
+stdout and stderr, terminates it in case
+it runs longer than specified.
+
+Invocation requires the command to be executed and optionally a hashref of options:
+
+=over
+
+=item C<timeout>
+
+Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9)
+which effectively terminates it and all of its children (direct or indirect).
+
+=item C<child_stdin>
+
+Specify some text that will be passed into C<STDIN> of the executed program.
+
+=item C<stdout_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stdout from the executing program.
+
+=item C<stderr_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stderr from the executing program.
+
+=back
+
+C<run_forked> will return a HASHREF with the following keys:
+
+=over
+
+=item C<exit_code>
+
+The exit code of the executed program.
+
+=item C<timeout>
+
+The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
+
+=item C<stdout>
+
+Holds the standard output of the executed command
+(or empty string if there were no stdout output; it's always defined!)
+
+=item C<stderr>
+
+Holds the standard error of the executed command
+(or empty string if there were no stderr output; it's always defined!)
+
+=item C<merged>
+
+Holds the standard output and error of the executed command merged into one stream
+(or empty string if there were no output at all; it's always defined!)
+
+=item C<err_msg>
+
+Holds some explanation in the case of an error.
+
+=back
+
+=cut
+
+sub run_forked {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ if (!can_use_run_forked()) {
+ Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
+ return;
+ }
+
+ my ($cmd, $opts) = @_;
+
+ if (!$cmd) {
+ Carp::carp("run_forked expects command to run");
+ return;
+ }
+
+ $opts = {} unless $opts;
+ $opts->{'timeout'} = 0 unless $opts->{'timeout'};
+
+ # sockets to pass child stdout to parent
+ my $child_stdout_socket;
+ my $parent_stdout_socket;
+
+ # sockets to pass child stderr to parent
+ my $child_stderr_socket;
+ my $parent_stderr_socket;
+
+ # sockets for child -> parent internal communication
+ my $child_info_socket;
+ my $parent_info_socket;
+
+ socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+
+ $child_stdout_socket->autoflush(1);
+ $parent_stdout_socket->autoflush(1);
+ $child_stderr_socket->autoflush(1);
+ $parent_stderr_socket->autoflush(1);
+ $child_info_socket->autoflush(1);
+ $parent_info_socket->autoflush(1);
+
+ my $start_time = time();
+
+ my $pid;
+ if ($pid = fork) {
+
+ # we are a parent
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ my $child_timedout = 0;
+ my $flags;
+
+ # prepare sockets to read from child
+
+ $flags = 0;
+ fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ # print "child $pid started\n";
+
+ my $child_finished = 0;
+ my $child_stdout = '';
+ my $child_stderr = '';
+ my $child_merged = '';
+ my $child_exit_code = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ my $child_child_pid;
+
+ while (!$child_finished) {
+ # user specified timeout
+ if ($opts->{'timeout'}) {
+ if (time() - $start_time > $opts->{'timeout'}) {
+ kill (-9, $pid);
+ $child_timedout = 1;
+ }
+ }
+
+ # give OS 10 seconds for correct return of waitpid,
+ # kill process after that and finish wait loop;
+ # shouldn't ever happen -- remove this code?
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ my $waitpid = waitpid($pid, WNOHANG);
+
+ # child finished, catch it's exit status
+ if ($waitpid ne 0 && $waitpid ne -1) {
+ $child_exit_code = $? >> 8;
+ }
+
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ next;
+ }
+
+ # child -> parent simple internal communication protocol
+ while (my $l = <$child_info_socket>) {
+ if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = $1;
+ $l = $2;
+ }
+ if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = undef;
+ $l = $2;
+ }
+ }
+
+ while (my $l = <$child_stdout_socket>) {
+ $child_stdout .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
+ $opts->{'stdout_handler'}->($l);
+ }
+ }
+ while (my $l = <$child_stderr_socket>) {
+ $child_stderr .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
+ $opts->{'stderr_handler'}->($l);
+ }
+ }
+
+ Time::HiRes::usleep(1);
+ }
+
+ # $child_pid_pid is not defined in two cases:
+ # * when our child was killed before
+ # it had chance to tell us the pid
+ # of the child it spawned. we can do
+ # nothing in this case :(
+ # * our child successfully reaped its child,
+ # we have nothing left to do in this case
+ #
+ # defined $child_pid_pid means child's child
+ # has not died but nobody is waiting for it,
+ # killing it brutaly.
+ #
+ if ($child_child_pid) {
+ kill_gently($child_child_pid);
+ }
+
+ # print "child $pid finished\n";
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $o = {
+ 'stdout' => $child_stdout,
+ 'stderr' => $child_stderr,
+ 'merged' => $child_merged,
+ 'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
+ 'exit_code' => $child_exit_code,
+ };
+
+ my $err_msg = '';
+ if ($o->{'exit_code'}) {
+ $err_msg .= "exited with code [$o->{'exit_code'}]\n";
+ }
+ if ($o->{'timeout'}) {
+ $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
+ }
+ if ($o->{'stdout'}) {
+ $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
+ }
+ if ($o->{'stderr'}) {
+ $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
+ }
+ $o->{'err_msg'} = $err_msg;
+
+ return $o;
+ }
+ else {
+ die("cannot fork: $!") unless defined($pid);
+
+ # create new process session for open3 call,
+ # so we hopefully can kill all the subprocesses
+ # which might be spawned in it (except for those
+ # which do setsid theirselves -- can't do anything
+ # with those)
+
+ POSIX::setsid() || die("Error running setsid: " . $!);
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $child_exit_code = open3_run($cmd, {
+ 'parent_info' => $parent_info_socket,
+ 'parent_stdout' => $parent_stdout_socket,
+ 'parent_stderr' => $parent_stderr_socket,
+ 'child_stdin' => $opts->{'child_stdin'},
+ });
+
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ exit $child_exit_code;
+ }
+}
+
+sub run {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ my %hash = @_;
+
+ ### if the user didn't provide a buffer, we'll store it here.
+ my $def_buf = '';
+
+ my($verbose,$cmd,$buffer,$timeout);
+ my $tmpl = {
+ verbose => { default => $VERBOSE, store => \$verbose },
+ buffer => { default => \$def_buf, store => \$buffer },
+ command => { required => 1, store => \$cmd,
+ allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
+ },
+ timeout => { default => 0, store => \$timeout },
+ };
+
+ unless( check( $tmpl, \%hash, $VERBOSE ) ) {
+ Carp::carp( loc( "Could not validate input: %1",
+ Params::Check->last_error ) );
+ return;
+ };
+
+ $cmd = _quote_args_vms( $cmd ) if IS_VMS;
+
+ ### strip any empty elements from $cmd if present
+ $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
+
+ my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
+ print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
+
+ ### did the user pass us a buffer to fill or not? if so, set this
+ ### flag so we know what is expected of us
+ ### XXX this is now being ignored. in the future, we could add diagnostic
+ ### messages based on this logic
+ #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
+
+ ### buffers that are to be captured
+ my( @buffer, @buff_err, @buff_out );
+
+ ### capture STDOUT
+ my $_out_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDOUT $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_out, $buf;
+ };
+
+ ### capture STDERR
+ my $_err_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDERR $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_err, $buf;
+ };
+
+
+ ### flag to indicate we have a buffer captured
+ my $have_buffer = $self->can_capture_buffer ? 1 : 0;
+
+ ### flag indicating if the subcall went ok
+ my $ok;
+
+ ### dont look at previous errors:
+ local $?;
+ local $@;
+ local $!;
+
+ ### we might be having a timeout set
+ eval {
+ local $SIG{ALRM} = sub { die bless sub {
+ ALARM_CLASS .
+ qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
+ }, ALARM_CLASS } if $timeout;
+ alarm $timeout || 0;
+
+ ### IPC::Run is first choice if $USE_IPC_RUN is set.
+ if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
+ ### ipc::run handlers needs the command as a string or an array ref
+
+ $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
+ if $DEBUG;
+
+ $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
+
+ ### since IPC::Open3 works on all platforms, and just fails on
+ ### win32 for capturing buffers, do that ideally
+ } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
+
+ $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
+ if $DEBUG;
+
+ ### in case there are pipes in there;
+ ### IPC::Open3 will call exec and exec will do the right thing
+ $ok = $self->_open3_run(
+ $cmd, $_out_handler, $_err_handler, $verbose
+ );
+
+ ### if we are allowed to run verbose, just dispatch the system command
+ } else {
+ $self->_debug( "# Using system(). Have buffer: $have_buffer" )
+ if $DEBUG;
+ $ok = $self->_system_run( $cmd, $verbose );
+ }
+
+ alarm 0;
+ };
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
+
+ my $err;
+ unless( $ok ) {
+ ### alarm happened
+ if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ $err = $@->(); # the error code is an expired alarm
+
+ ### another error happened, set by the dispatchub
+ } else {
+ $err = $self->error;
+ }
+ }
+
+ ### fill the buffer;
+ $$buffer = join '', @buffer if @buffer;
+
+ ### return a list of flags and buffers (if available) in list
+ ### context, or just a simple 'ok' in scalar
+ return wantarray
+ ? $have_buffer
+ ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
+ : ($ok, $err )
+ : $ok
+
+
+}
+
+sub _open3_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+ my $verbose = shift || 0;
+
+ ### Following code are adapted from Friar 'abstracts' in the
+ ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
+ ### XXX that code didn't work.
+ ### we now use the following code, thanks to theorbtwo
+
+ ### define them beforehand, so we always have defined FH's
+ ### to read from.
+ use Symbol;
+ my $kidout = Symbol::gensym();
+ my $kiderror = Symbol::gensym();
+
+ ### Dup the filehandle so we can pass 'our' STDIN to the
+ ### child process. This stops us from having to pump input
+ ### from ourselves to the childprocess. However, we will need
+ ### to revive the FH afterwards, as IPC::Open3 closes it.
+ ### We'll do the same for STDOUT and STDERR. It works without
+ ### duping them on non-unix derivatives, but not on win32.
+ my @fds_to_dup = ( IS_WIN32 && !$verbose
+ ? qw[STDIN STDOUT STDERR]
+ : qw[STDIN]
+ );
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ ### dont stringify @$cmd, so spaces in filenames/paths are
+ ### treated properly
+ my $pid = eval {
+ IPC::Open3::open3(
+ '<&STDIN',
+ (IS_WIN32 ? '>&STDOUT' : $kidout),
+ (IS_WIN32 ? '>&STDERR' : $kiderror),
+ ( ref $cmd ? @$cmd : $cmd ),
+ );
+ };
+
+ ### open3 error occurred
+ if( $@ and $@ =~ /^open3:/ ) {
+ $self->ok( 0 );
+ $self->error( $@ );
+ return;
+ };
+
+ ### use OUR stdin, not $kidin. Somehow,
+ ### we never get the input.. so jump through
+ ### some hoops to do it :(
+ my $selector = IO::Select->new(
+ (IS_WIN32 ? \*STDERR : $kiderror),
+ \*STDIN,
+ (IS_WIN32 ? \*STDOUT : $kidout)
+ );
+
+ STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
+ $kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
+ $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
+
+ ### add an epxlicit break statement
+ ### code courtesy of theorbtwo from #london.pm
+ my $stdout_done = 0;
+ my $stderr_done = 0;
+ OUTER: while ( my @ready = $selector->can_read ) {
+
+ for my $h ( @ready ) {
+ my $buf;
+
+ ### $len is the amount of bytes read
+ my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
+
+ ### see perldoc -f sysread: it returns undef on error,
+ ### so bail out.
+ if( not defined $len ) {
+ warn(loc("Error reading from process: %1", $!));
+ last OUTER;
+ }
+
+ ### check for $len. it may be 0, at which point we're
+ ### done reading, so don't try to process it.
+ ### if we would print anyway, we'd provide bogus information
+ $_out_handler->( "$buf" ) if $len && $h == $kidout;
+ $_err_handler->( "$buf" ) if $len && $h == $kiderror;
+
+ ### Wait till child process is done printing to both
+ ### stdout and stderr.
+ $stdout_done = 1 if $h == $kidout and $len == 0;
+ $stderr_done = 1 if $h == $kiderror and $len == 0;
+ last OUTER if ($stdout_done && $stderr_done);
+ }
+ }
+
+ waitpid $pid, 0; # wait for it to die
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ ### done in the parent call now
+ # $self->__reopen_fds( @fds_to_dup );
+
+ ### some error occurred
+ if( $? ) {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ return;
+ } else {
+ return $self->ok( 1 );
+ }
+}
+
+### text::parsewords::shellwordss() uses unix semantics. that will break
+### on win32
+{ my $parse_sub = IS_WIN32
+ ? __PACKAGE__->can('_split_like_shell_win32')
+ : Text::ParseWords->can('shellwords');
+
+ sub _ipc_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+
+ STDOUT->autoflush(1); STDERR->autoflush(1);
+
+ ### a command like:
+ # [
+ # '/usr/bin/gzip',
+ # '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
+ # '|',
+ # '/usr/bin/tar',
+ # '-tf -'
+ # ]
+ ### needs to become:
+ # [
+ # ['/usr/bin/gzip', '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
+ # '|',
+ # ['/usr/bin/tar', '-tf -']
+ # ]
+
+
+ my @command;
+ my $special_chars;
+
+ my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
+ if( ref $cmd ) {
+ my $aref = [];
+ for my $item (@$cmd) {
+ if( $item =~ $re ) {
+ push @command, $aref, $item;
+ $aref = [];
+ $special_chars .= $1;
+ } else {
+ push @$aref, $item;
+ }
+ }
+ push @command, $aref;
+ } else {
+ @command = map { if( $_ =~ $re ) {
+ $special_chars .= $1; $_;
+ } else {
+# [ split /\s+/ ]
+ [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
+ }
+ } split( /\s*$re\s*/, $cmd );
+ }
+
+ ### if there's a pipe in the command, *STDIN needs to
+ ### be inserted *BEFORE* the pipe, to work on win32
+ ### this also works on *nix, so we should do it when possible
+ ### this should *also* work on multiple pipes in the command
+ ### if there's no pipe in the command, append STDIN to the back
+ ### of the command instead.
+ ### XXX seems IPC::Run works it out for itself if you just
+ ### dont pass STDIN at all.
+ # if( $special_chars and $special_chars =~ /\|/ ) {
+ # ### only add STDIN the first time..
+ # my $i;
+ # @command = map { ($_ eq '|' && not $i++)
+ # ? ( \*STDIN, $_ )
+ # : $_
+ # } @command;
+ # } else {
+ # push @command, \*STDIN;
+ # }
+
+ # \*STDIN is already included in the @command, see a few lines up
+ my $ok = eval { IPC::Run::run( @command,
+ fileno(STDOUT).'>',
+ $_out_handler,
+ fileno(STDERR).'>',
+ $_err_handler
+ )
+ };
+
+ ### all is well
+ if( $ok ) {
+ return $self->ok( $ok );
+
+ ### some error occurred
+ } else {
+ $self->ok( 0 );
+
+ ### if the eval fails due to an exception, deal with it
+ ### unless it's an alarm
+ if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
+ $self->error( $@ );
+
+ ### if it *is* an alarm, propagate
+ } elsif( $@ ) {
+ die $@;
+
+ ### some error in the sub command
+ } else {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ }
+
+ return;
+ }
+ }
+}
+
+sub _system_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $verbose = shift || 0;
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### system returns 'true' on failure -- the exit code of the cmd
+ $self->ok( 1 );
+ system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ };
+
+ ### done in the parent call now
+ #$self->__reopen_fds( @fds_to_dup );
+
+ return unless $self->ok;
+ return $self->ok;
+}
+
+{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
+
+
+ sub __fix_cmd_whitespace_and_special_chars {
+ my $self = shift;
+ my $cmd = shift;
+
+ ### command has a special char in it
+ if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
+
+ ### since we have special chars, we have to quote white space
+ ### this *may* conflict with the parsing :(
+ my $fixed;
+ my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
+
+ $self->_debug( "# Quoted $fixed arguments containing whitespace" )
+ if $DEBUG && $fixed;
+
+ ### stringify it, so the special char isn't escaped as argument
+ ### to the program
+ $cmd = join ' ', @cmd;
+ }
+
+ return $cmd;
+ }
+}
+
+### Command-line arguments (but not the command itself) must be quoted
+### to ensure case preservation. Borrowed from Module::Build with adaptations.
+### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
+### quoting for run() on VMS
+sub _quote_args_vms {
+ ### Returns a command string with proper quoting so that the subprocess
+ ### sees this same list of args, or if we get a single arg that is an
+ ### array reference, quote the elements of it (except for the first)
+ ### and return the reference.
+ my @args = @_;
+ my $got_arrayref = (scalar(@args) == 1
+ && UNIVERSAL::isa($args[0], 'ARRAY'))
+ ? 1
+ : 0;
+
+ @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
+
+ my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
+
+ ### Do not quote qualifiers that begin with '/' or previously quoted args.
+ map { if (/^[^\/\"]/) {
+ $_ =~ s/\"/""/g; # escape C<"> by doubling
+ $_ = q(").$_.q(");
+ }
+ }
+ ($got_arrayref ? @{$args[0]}
+ : @args
+ );
+
+ $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
+
+ return $got_arrayref ? $args[0]
+ : join(' ', @args);
+}
+
+
+### XXX this is cribbed STRAIGHT from M::B 0.30 here:
+### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
+### XXX this *should* be integrated into text::parsewords
+sub _split_like_shell_win32 {
+ # As it turns out, Windows command-parsing is very different from
+ # Unix command-parsing. Double-quotes mean different things,
+ # backslashes don't necessarily mean escapes, and so on. So we
+ # can't use Text::ParseWords::shellwords() to break a command string
+ # into words. The algorithm below was bashed out by Randy and Ken
+ # (mostly Randy), and there are a lot of regression tests, so we
+ # should feel free to adjust if desired.
+
+ local $_ = shift;
+
+ my @argv;
+ return @argv unless defined() && length();
+
+ my $arg = '';
+ my( $i, $quote_mode ) = ( 0, 0 );
+
+ while ( $i < length() ) {
+
+ my $ch = substr( $_, $i , 1 );
+ my $next_ch = substr( $_, $i+1, 1 );
+
+ if ( $ch eq '\\' && $next_ch eq '"' ) {
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
+ $arg .= '\\';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
+ $quote_mode = !$quote_mode;
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
+ ( $i + 2 == length() ||
+ substr( $_, $i + 2, 1 ) eq ' ' )
+ ) { # for cases like: a"" => [ 'a' ]
+ push( @argv, $arg );
+ $arg = '';
+ $i += 2;
+ } elsif ( $ch eq '"' ) {
+ $quote_mode = !$quote_mode;
+ } elsif ( $ch eq ' ' && !$quote_mode ) {
+ push( @argv, $arg ) if $arg;
+ $arg = '';
+ ++$i while substr( $_, $i + 1, 1 ) eq ' ';
+ } else {
+ $arg .= $ch;
+ }
+
+ $i++;
+ }
+
+ push( @argv, $arg ) if defined( $arg ) && length( $arg );
+ return @argv;
+}
+
+
+
+{ use File::Spec;
+ use Symbol;
+
+ my %Map = (
+ STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
+ STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
+ STDIN => [qw|<&|, \*STDIN, Symbol::gensym() ],
+ );
+
+ ### dups FDs and stores them in a cache
+ sub __dup_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open $glob, $redir . fileno($fh) or (
+ Carp::carp(loc("Could not dup '$name': %1", $!)),
+ return
+ );
+
+ ### we should re-open this filehandle right now, not
+ ### just dup it
+ ### Use 2-arg version of open, as 5.5.x doesn't support
+ ### 3-arg version =/
+ if( $redir eq '>&' ) {
+ open( $fh, '>' . File::Spec->devnull ) or (
+ Carp::carp(loc("Could not reopen '$name': %1", $!)),
+ return
+ );
+ }
+ }
+
+ return 1;
+ }
+
+ ### reopens FDs from the cache
+ sub __reopen_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open( $fh, $redir . fileno($glob) ) or (
+ Carp::carp(loc("Could not restore '$name': %1", $!)),
+ return
+ );
+
+ ### close this FD, we're not using it anymore
+ close $glob;
+ }
+ return 1;
+
+ }
+}
+
+sub _debug {
+ my $self = shift;
+ my $msg = shift or return;
+ my $level = shift || 0;
+
+ local $Carp::CarpLevel += $level;
+ Carp::carp($msg);
+
+ return 1;
+}
+
+sub _pp_child_error {
+ my $self = shift;
+ my $cmd = shift or return;
+ my $ce = shift or return;
+ my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
+
+
+ my $str;
+ if( $ce == -1 ) {
+ ### Include $! in the error message, so that the user can
+ ### see 'No such file or directory' versus 'Permission denied'
+ ### versus 'Cannot fork' or whatever the cause was.
+ $str = "Failed to execute '$pp_cmd': $!";
+
+ } elsif ( $ce & 127 ) {
+ ### some signal
+ $str = loc( "'%1' died with signal %d, %s coredump\n",
+ $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
+
+ } else {
+ ### Otherwise, the command run but gave error status.
+ $str = "'$pp_cmd' exited with value " . ($ce >> 8);
+ }
+
+ $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
+
+ return $str;
+}
+
+1;
+
+=head2 $q = QUOTE
+
+Returns the character used for quoting strings on this platform. This is
+usually a C<'> (single quote) on most systems, but some systems use different
+quotes. For example, C<Win32> uses C<"> (double quote).
+
+You can use it as follows:
+
+ use IPC::Cmd qw[run QUOTE];
+ my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
+
+This makes sure that C<foo bar> is treated as a string, rather than two
+seperate arguments to the C<echo> function.
+
+__END__
+
+=head1 HOW IT WORKS
+
+C<run> will try to execute your command using the following logic:
+
+=over 4
+
+=item *
+
+If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
+is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
+the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity
+settings honored cleanly.
+
+=item *
+
+Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
+(See the C<GLOBAL VARIABLES> Section), try to execute the command using
+C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
+interactive commands will still execute cleanly, and also your verbosity
+settings will be adhered to nicely;
+
+=item *
+
+Otherwise, if you have the verbose argument set to true, we fall back
+to a simple system() call. We cannot capture any buffers, but
+interactive commands will still work.
+
+=item *
+
+Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
+system() call with your command and then re-open STDERR and STDOUT.
+This is the method of last resort and will still allow you to execute
+your commands cleanly. However, no buffers will be available.
+
+=back
+
+=head1 Global Variables
+
+The behaviour of IPC::Cmd can be altered by changing the following
+global variables:
+
+=head2 $IPC::Cmd::VERBOSE
+
+This controls whether IPC::Cmd will print any output from the
+commands to the screen or not. The default is 0;
+
+=head2 $IPC::Cmd::USE_IPC_RUN
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Run>
+when available and suitable. Defaults to true if you are on C<Win32>.
+
+=head2 $IPC::Cmd::USE_IPC_OPEN3
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
+when available and suitable. Defaults to true.
+
+=head2 $IPC::Cmd::WARN
+
+This variable controls whether run time warnings should be issued, like
+the failure to load an C<IPC::*> module you explicitly requested.
+
+Defaults to true. Turn this off at your own risk.
+
+=head1 Caveats
+
+=over 4
+
+=item Whitespace and IPC::Open3 / system()
+
+When using C<IPC::Open3> or C<system>, if you provide a string as the
+C<command> argument, it is assumed to be appropriately escaped. You can
+use the C<QUOTE> constant to use as a portable quote character (see above).
+However, if you provide and C<Array Reference>, special rules apply:
+
+If your command contains C<Special Characters> (< > | &), it will
+be internally stringified before executing the command, to avoid that these
+special characters are escaped and passed as arguments instead of retaining
+their special meaning.
+
+However, if the command contained arguments that contained whitespace,
+stringifying the command would loose the significance of the whitespace.
+Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
+command if the command is passed as an arrayref and contains special characters.
+
+=item Whitespace and IPC::Run
+
+When using C<IPC::Run>, if you provide a string as the C<command> argument,
+the string will be split on whitespace to determine the individual elements
+of your command. Although this will usually just Do What You Mean, it may
+break if you have files or commands with whitespace in them.
+
+If you do not wish this to happen, you should provide an array
+reference, where all parts of your command are already separated out.
+Note however, if there's extra or spurious whitespace in these parts,
+the parser or underlying code may not interpret it correctly, and
+cause an error.
+
+Example:
+The following code
+
+ gzip -cdf foo.tar.gz | tar -xf -
+
+should either be passed as
+
+ "gzip -cdf foo.tar.gz | tar -xf -"
+
+or as
+
+ ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
+
+But take care not to pass it as, for example
+
+ ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
+
+Since this will lead to issues as described above.
+
+
+=item IO Redirect
+
+Currently it is too complicated to parse your command for IO
+Redirections. For capturing STDOUT or STDERR there is a work around
+however, since you can just inspect your buffers for the contents.
+
+=item Interleaving STDOUT/STDERR
+
+Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
+bursts of output from a program, ie this sample:
+
+ for ( 1..4 ) {
+ $_ % 2 ? print STDOUT $_ : print STDERR $_;
+ }
+
+IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
+the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
+
+It should have been 1, 2, 3, 4.
+
+This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
+STDOUT and STDERR
+
+=back
+
+=head1 See Also
+
+C<IPC::Run>, C<IPC::Open3>
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to James Mastros and Martijn van der Streek for their
+help in getting IPC::Open3 to behave nicely.
+
+Thanks to Petya Kohts for the C<run_forked> code.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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
diff --git a/Master/tlpkg/tlperl/lib/IPC/Open2.pm b/Master/tlpkg/tlperl/lib/IPC/Open2.pm
new file mode 100644
index 00000000000..5f555bcfa4e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IPC/Open2.pm
@@ -0,0 +1,121 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.03;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2 - open a process for both reading and writing using open2()
+
+=head1 SYNOPSIS
+
+ use IPC::Open2;
+
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args');
+ # or without using the shell
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args');
+
+ # or with handle autovivification
+ my($chld_out, $chld_in);
+ $pid = open2($chld_out, $chld_in, 'some cmd and args');
+ # or without using the shell
+ $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args');
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+The open2() function runs the given $cmd and connects $chld_out for
+reading and $chld_in for writing. It's what you think should work
+when you try
+
+ $pid = open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $chld_out is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle. If $chld_in is a string that begins with
+C<< <& >>, then $chld_in will be closed in the parent, and the child will
+read from it directly. In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
+
+open2() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+This whole affair is quite dangerous, as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it. This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time. Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING
+
+The order of arguments differs from that of open3().
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', scalar caller,
+ $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
diff --git a/Master/tlpkg/tlperl/lib/IPC/Open3.pm b/Master/tlpkg/tlperl/lib/IPC/Open3.pm
new file mode 100644
index 00000000000..82c20ae8287
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IPC/Open3.pm
@@ -0,0 +1,376 @@
+package IPC::Open3;
+
+use strict;
+no strict 'refs'; # because users pass me bareword filehandles
+our ($VERSION, @ISA, @EXPORT);
+
+require Exporter;
+
+use Carp;
+use Symbol qw(gensym qualify);
+
+$VERSION = 1.05;
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+=head1 NAME
+
+IPC::Open3 - open a process for reading, writing, and error handling using open3()
+
+=head1 SYNOPSIS
+
+ $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
+ 'some cmd and args', 'optarg', ...);
+
+ my($wtr, $rdr, $err);
+ use Symbol 'gensym'; $err = gensym;
+ $pid = open3($wtr, $rdr, $err,
+ 'some cmd and args', 'optarg', ...);
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+Extremely similar to open2(), open3() spawns the given $cmd and
+connects CHLD_OUT for reading from the child, CHLD_IN for writing to
+the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the
+same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
+are on the same filehandle (this means that an autovivified lexical
+cannot be used for the STDERR filehandle, see SYNOPSIS). The CHLD_IN
+will have autoflush turned on.
+
+If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
+parent, and the child will read from it directly. If CHLD_OUT or
+CHLD_ERR begins with C<< >& >>, then the child will send output
+directly to that filehandle. In both cases, there will be a dup(2)
+instead of a pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+The filehandles may also be integers, in which case they are understood
+as file descriptors.
+
+open3() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open3:/>. However,
+C<exec> failures in the child (such as no such file or permission denied),
+are just reported to CHLD_ERR, as it is not possible to trap them.
+
+If the child process dies for any reason, the next write to CHLD_IN is
+likely to generate a SIGPIPE in the parent, which is fatal by default.
+So you may wish to handle this signal.
+
+Note if you specify C<-> as the command, in an analogous fashion to
+C<open(FOO, "-|")> the child process will just be the forked Perl
+process rather than an external command. This feature isn't yet
+supported on Win32 platforms.
+
+open3() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll want
+to use select() or the IO::Select, which means you'd best use
+sysread() instead of readline() for normal stuff.
+
+This is very dangerous, as you may block forever. It assumes it's
+going to talk to something like B<bc>, both writing to it and reading
+from it. This is presumably safe because you "know" that commands
+like B<bc> will read a line at a time and output a line at a time.
+Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=head1 See Also
+
+=over 4
+
+=item L<IPC::Open2>
+
+Like Open3 but without STDERR catpure.
+
+=item L<IPC::Run>
+
+This is a CPAN module that has better error handling and more facilities
+than Open3.
+
+=back
+
+=head1 WARNING
+
+The order of arguments differs from that of open2().
+
+=cut
+
+# &open3: Marc Horowitz <marc@mit.edu>
+# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
+# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
+# fixed for autovivving FHs, tchrist again
+# allow fd numbers to be used, by Frank Tobin
+# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
+#
+# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#
+# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+#
+# spawn the given $cmd and connect rdr for
+# reading, wtr for writing, and err for errors.
+# if err is '', or the same as rdr, then stdout and
+# stderr of the child are on the same fh. returns pid
+# of child (or dies on failure).
+
+
+# if wtr begins with '<&', then wtr will be closed in the parent, and
+# the child will read from it directly. if rdr or err begins with
+# '>&', then the child will send output directly to that fd. In both
+# cases, there will be a dup() instead of a pipe() made.
+
+
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+our $Me = 'open3 (bug)'; # you should never see this, it's always localized
+
+# Fatal.pm needs to be fixed WRT prototypes.
+
+sub xfork {
+ my $pid = fork;
+ defined $pid or croak "$Me: fork failed: $!";
+ return $pid;
+}
+
+sub xpipe {
+ pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
+}
+
+# I tried using a * prototype character for the filehandle but it still
+# disallows a bearword while compiling under strict subs.
+
+sub xopen {
+ open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+}
+
+sub xclose {
+ close $_[0] or croak "$Me: close($_[0]) failed: $!";
+}
+
+sub fh_is_fd {
+ return $_[0] =~ /\A=?(\d+)\z/;
+}
+
+sub xfileno {
+ return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
+ return fileno $_[0];
+}
+
+use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32';
+
+sub _open3 {
+ local $Me = shift;
+ my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+ my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
+
+ if (@cmd > 1 and $cmd[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ }
+
+ # simulate autovivification of filehandles because
+ # it's too ugly to use @_ throughout to make perl do it for us
+ # tchrist 5-Mar-00
+
+ unless (eval {
+ $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
+ $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
+ 1; })
+ {
+ # must strip crud for croak to add back, or looks ugly
+ $@ =~ s/(?<=value attempted) at .*//s;
+ croak "$Me: $@";
+ }
+
+ $dad_err ||= $dad_rdr;
+
+ $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
+ $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
+ $dup_err = ($dad_err =~ s/^[<>]&//);
+
+ # force unqualified filehandles into caller's package
+ $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
+ $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
+ $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
+
+ my $kid_rdr = gensym;
+ my $kid_wtr = gensym;
+ my $kid_err = gensym;
+
+ xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
+ xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
+ xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+
+ $kidpid = DO_SPAWN ? -1 : xfork;
+ if ($kidpid == 0) { # Kid
+ # A tie in the parent should not be allowed to cause problems.
+ untie *STDIN;
+ untie *STDOUT;
+ # If she wants to dup the kid's stderr onto her stdout I need to
+ # save a copy of her stdout before I put something else there.
+ if ($dad_rdr ne $dad_err && $dup_err
+ && xfileno($dad_err) == fileno(STDOUT)) {
+ my $tmp = gensym;
+ xopen($tmp, ">&$dad_err");
+ $dad_err = $tmp;
+ }
+
+ if ($dup_wtr) {
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
+ } else {
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&=" . fileno $kid_rdr;
+ }
+ if ($dup_rdr) {
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
+ } else {
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ # I have to use a fileno here because in this one case
+ # I'm doing a dup but the filehandle might be a reference
+ # (from the special case above).
+ xopen \*STDERR, ">&" . xfileno($dad_err)
+ if fileno(STDERR) != xfileno($dad_err);
+ } else {
+ xclose $dad_err;
+ xopen \*STDERR, ">&=" . fileno $kid_err;
+ }
+ } else {
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+ }
+ return 0 if ($cmd[0] eq '-');
+ local($")=(" ");
+ exec @cmd or do {
+ carp "$Me: exec of @cmd failed";
+ eval { require POSIX; POSIX::_exit(255); };
+ exit 255;
+ };
+ } elsif (DO_SPAWN) {
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
+
+ my @close;
+ if ($dup_wtr) {
+ $kid_rdr = \*{$dad_wtr};
+ push @close, $kid_rdr;
+ } else {
+ push @close, \*{$dad_wtr}, $kid_rdr;
+ }
+ if ($dup_rdr) {
+ $kid_wtr = \*{$dad_rdr};
+ push @close, $kid_wtr;
+ } else {
+ push @close, \*{$dad_rdr}, $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ $kid_err = \*{$dad_err};
+ push @close, $kid_err;
+ } else {
+ push @close, \*{$dad_err}, $kid_err;
+ }
+ } else {
+ $kid_err = $kid_wtr;
+ }
+ require IO::Pipe;
+ $kidpid = eval {
+ spawn_with_handles( [ { mode => 'r',
+ open_as => $kid_rdr,
+ handle => \*STDIN },
+ { mode => 'w',
+ open_as => $kid_wtr,
+ handle => \*STDOUT },
+ { mode => 'w',
+ open_as => $kid_err,
+ handle => \*STDERR },
+ ], \@close, @cmd);
+ };
+ die "$Me: $@" if $@;
+ }
+
+ xclose $kid_rdr if !$dup_wtr;
+ xclose $kid_wtr if !$dup_rdr;
+ xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+ # If the write handle is a dup give it away entirely, close my copy
+ # of it.
+ xclose $dad_wtr if $dup_wtr;
+
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+
+sub open3 {
+ if (@_ < 4) {
+ local $" = ', ';
+ croak "open3(@_): not enough arguments";
+ }
+ return _open3 'open3', scalar caller, @_
+}
+
+sub spawn_with_handles {
+ my $fds = shift; # Fields: handle, mode, open_as
+ my $close_in_child = shift;
+ my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
+ require Fcntl;
+
+ foreach $fd (@$fds) {
+ $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
+ }
+ foreach $fd (@$fds) {
+ bless $fd->{handle}, 'IO::Handle'
+ unless eval { $fd->{handle}->isa('IO::Handle') } ;
+ # If some of handles to redirect-to coincide with handles to
+ # redirect, we need to use saved variants:
+ $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
+ $fd->{mode});
+ }
+ unless ($^O eq 'MSWin32') {
+ # Stderr may be redirected below, so we save the err text:
+ foreach $fd (@$close_in_child) {
+ fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
+ unless $saved{fileno $fd}; # Do not close what we redirect!
+ }
+ }
+
+ unless (@errs) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
+ }
+
+ foreach $fd (@$fds) {
+ $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
+ $fd->{tmp_copy}->close or croak "Can't close: $!";
+ }
+ croak join "\n", @errs if @errs;
+ return $pid;
+}
+
+1; # so require is happy
diff --git a/Master/tlpkg/tlperl/lib/List/Util.pm b/Master/tlpkg/tlperl/lib/List/Util.pm
new file mode 100644
index 00000000000..2b51a69d79b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/List/Util.pm
@@ -0,0 +1,233 @@
+# List::Util.pm
+#
+# Copyright (c) 1997-2009 Graham Barr <gbarr@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.
+#
+# This module is normally only loaded if the XS module is not available
+
+package List::Util;
+
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY);
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
+$VERSION = "1.22";
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+eval {
+ # PERL_DL_NONLAZY must be false, or any errors in loading will just
+ # cause the perl code to be tested
+ local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
+ eval {
+ require XSLoader;
+ XSLoader::load('List::Util', $XS_VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap List::Util $XS_VERSION;
+ };
+} unless $TESTING_PERL_ONLY;
+
+
+if (!defined &sum) {
+ require List::Util::PP;
+ List::Util::PP->import;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+List::Util - A selection of general-utility list subroutines
+
+=head1 SYNOPSIS
+
+ use List::Util qw(first max maxstr min minstr reduce shuffle sum);
+
+=head1 DESCRIPTION
+
+C<List::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<List::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item first BLOCK LIST
+
+Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
+of LIST in turn. C<first> returns the first element where the result from
+BLOCK is a true value. If BLOCK never returns true or LIST was empty then
+C<undef> is returned.
+
+ $foo = first { defined($_) } @list # first defined value in @list
+ $foo = first { $_ > $value } @list # first value in @list which
+ # is greater than $value
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
+
+for example wanted() could be defined() which would return the first
+defined value in @list
+
+=item max LIST
+
+Returns the entry in the list with the highest numerical value. If the
+list is empty then C<undef> is returned.
+
+ $foo = max 1..10 # 10
+ $foo = max 3,9,12 # 12
+ $foo = max @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a > $b ? $a : $b } 1..10
+
+=item maxstr LIST
+
+Similar to C<max>, but treats all the entries in the list as strings
+and returns the highest string as defined by the C<gt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'Z'
+ $foo = maxstr "hello","world" # "world"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
+
+=item min LIST
+
+Similar to C<max> but returns the entry in the list with the lowest
+numerical value. If the list is empty then C<undef> is returned.
+
+ $foo = min 1..10 # 1
+ $foo = min 3,9,12 # 3
+ $foo = min @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10
+
+=item minstr LIST
+
+Similar to C<min>, but treats all the entries in the list as strings
+and returns the lowest string as defined by the C<lt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = minstr 'A'..'Z' # 'A'
+ $foo = minstr "hello","world" # "hello"
+ $foo = minstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
+
+=item reduce BLOCK LIST
+
+Reduces LIST by calling BLOCK, in a scalar context, multiple times,
+setting C<$a> and C<$b> each time. The first call will be with C<$a>
+and C<$b> set to the first two elements of the list, subsequent
+calls will be done by setting C<$a> to the result of the previous
+call and C<$b> to the next element in the list.
+
+Returns the result of the last call to BLOCK. If LIST is empty then
+C<undef> is returned. If LIST only contains one element then that
+element is returned and BLOCK is not executed.
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10 # min
+ $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
+ $foo = reduce { $a + $b } 1 .. 10 # sum
+ $foo = reduce { $a . $b } @bar # concat
+
+If your algorithm requires that C<reduce> produce an identity value, then
+make sure that you always pass that identity value as the first argument to prevent
+C<undef> being returned
+
+ $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value
+
+=item shuffle LIST
+
+Returns the elements of LIST in a random order
+
+ @cards = shuffle 0..51 # 0..51 in a random order
+
+=item sum LIST
+
+Returns the sum of all the elements in LIST. If LIST is empty then
+C<undef> is returned.
+
+ $foo = sum 1..10 # 55
+ $foo = sum 3,9,12 # 24
+ $foo = sum @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a + $b } 1..10
+
+If your algorithm requires that C<sum> produce an identity of 0, then
+make sure that you always pass C<0> as the first argument to prevent
+C<undef> being returned
+
+ $foo = sum 0, @values;
+
+=back
+
+=head1 KNOWN BUGS
+
+With perl versions prior to 5.005 there are some cases where reduce
+will return an incorrect result. This will show up as test 7 of
+reduce.t failing.
+
+=head1 SUGGESTED ADDITIONS
+
+The following are additions that have been requested, but I have been reluctant
+to add due to them being very simple to implement in perl
+
+ # One argument is true
+
+ sub any { $_ && return 1 for @_; 0 }
+
+ # All arguments are true
+
+ sub all { $_ || return 0 for @_; 1 }
+
+ # All arguments are false
+
+ sub none { $_ && return 0 for @_; 1 }
+
+ # One argument is false
+
+ sub notall { $_ || return 1 for @_; 0 }
+
+ # How many elements are true
+
+ sub true { scalar grep { $_ } @_ }
+
+ # How many elements are false
+
+ sub false { scalar grep { !$_ } @_ }
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::MoreUtils>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2007 Graham Barr <gbarr@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.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/List/Util/PP.pm b/Master/tlpkg/tlperl/lib/List/Util/PP.pm
new file mode 100644
index 00000000000..425f1c50159
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/List/Util/PP.pm
@@ -0,0 +1,83 @@
+# List::Util::PP.pm
+#
+# Copyright (c) 1997-2009 Graham Barr <gbarr@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 List::Util::PP;
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT $VERSION $a $b);
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(first min max minstr maxstr reduce sum shuffle);
+$VERSION = "1.22";
+$VERSION = eval $VERSION;
+
+sub reduce (&@) {
+ my $code = shift;
+ require Scalar::Util;
+ my $type = Scalar::Util::reftype($code);
+ unless($type and $type eq 'CODE') {
+ require Carp;
+ Carp::croak("Not a subroutine reference");
+ }
+ no strict 'refs';
+
+ return shift unless @_ > 1;
+
+ use vars qw($a $b);
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = shift;
+ foreach (@_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+sub first (&@) {
+ my $code = shift;
+ require Scalar::Util;
+ my $type = Scalar::Util::reftype($code);
+ unless($type and $type eq 'CODE') {
+ require Carp;
+ Carp::croak("Not a subroutine reference");
+ }
+
+ foreach (@_) {
+ return $_ if &{$code}();
+ }
+
+ undef;
+}
+
+
+sub sum (@) { reduce { $a + $b } @_ }
+
+sub min (@) { reduce { $a < $b ? $a : $b } @_ }
+
+sub max (@) { reduce { $a > $b ? $a : $b } @_ }
+
+sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
+
+sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
+
+sub shuffle (@) {
+ my @a=\(@_);
+ my $n;
+ my $i=@_;
+ map {
+ $n = rand($i--);
+ (${$a[$n]}, $a[$n] = $a[$i])[0];
+ } @_;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/List/Util/XS.pm b/Master/tlpkg/tlperl/lib/List/Util/XS.pm
new file mode 100644
index 00000000000..76bf6469c40
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/List/Util/XS.pm
@@ -0,0 +1,45 @@
+package List::Util::XS;
+use strict;
+use vars qw($VERSION);
+use List::Util;
+
+$VERSION = "1.22"; # FIXUP
+$VERSION = eval $VERSION; # FIXUP
+
+sub _VERSION { # FIXUP
+ require Carp;
+ Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled")
+ if defined $_[1];
+ $VERSION;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+List::Util::XS - Indicate if List::Util was compiled with a C compiler
+
+=head1 SYNOPSIS
+
+ use List::Util::XS 1.20;
+
+=head1 DESCRIPTION
+
+C<List::Util::XS> can be used as a dependency to ensure List::Util was
+installed using a C compiler and that the XS version is installed.
+
+During installation C<$List::Util::XS::VERSION> will be set to
+C<undef> if the XS was not compiled.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Graham Barr <gbarr@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.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Locale/Constants.pm b/Master/tlpkg/tlperl/lib/Locale/Constants.pm
new file mode 100644
index 00000000000..d8ef8f7e21a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Constants.pm
@@ -0,0 +1,31 @@
+#
+# Locale::Constants - defined constants for identifying codesets
+#
+# $Id: Constants.pm,v 2.7 2004/06/10 21:19:34 neilb Exp $
+#
+
+package Locale::Constants;
+use strict;
+
+require Exporter;
+
+#-----------------------------------------------------------------------
+# Public Global Variables
+#-----------------------------------------------------------------------
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+@ISA = qw(Exporter);
+@EXPORT = qw(LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 LOCALE_CODE_NUMERIC
+ LOCALE_CODE_DEFAULT);
+
+#-----------------------------------------------------------------------
+# Constants
+#-----------------------------------------------------------------------
+use constant LOCALE_CODE_ALPHA_2 => 1;
+use constant LOCALE_CODE_ALPHA_3 => 2;
+use constant LOCALE_CODE_NUMERIC => 3;
+
+use constant LOCALE_CODE_DEFAULT => LOCALE_CODE_ALPHA_2;
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Constants.pod b/Master/tlpkg/tlperl/lib/Locale/Constants.pod
new file mode 100644
index 00000000000..ae42abbec97
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Constants.pod
@@ -0,0 +1,76 @@
+
+=head1 NAME
+
+Locale::Constants - constants for Locale codes
+
+=head1 SYNOPSIS
+
+ use Locale::Constants;
+
+ $codeset = LOCALE_CODE_ALPHA_2;
+
+=head1 DESCRIPTION
+
+B<Locale::Constants> defines symbols which are used in
+the four modules from the Locale-Codes distribution:
+
+ Locale::Language
+ Locale::Country
+ Locale::Currency
+ Locale::Script
+
+B<Note:> at the moment only Locale::Country and Locale::Script
+support more than one code set.
+
+The symbols defined are used to specify which codes you
+want to be used:
+
+ LOCALE_CODE_ALPHA_2
+ LOCALE_CODE_ALPHA_3
+ LOCALE_CODE_NUMERIC
+
+You shouldn't have to C<use> this module directly yourself -
+it is used by the three Locale modules, which in turn export
+the symbols.
+
+=head1 KNOWN BUGS AND LIMITATIONS
+
+None at the moment.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Locale::Language
+
+Codes for identification of languages.
+
+=item Locale::Country
+
+Codes for identification of countries.
+
+=item Locale::Script
+
+Codes for identification of scripts.
+
+=item Locale::Currency
+
+Codes for identification of currencies and funds.
+
+=back
+
+=head1 AUTHOR
+
+Neil Bowers E<lt>neil@bowers.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002-2004, Neil Bowers.
+
+Copyright (C) 2001, Canon Research Centre Europe (CRE).
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Country.pm b/Master/tlpkg/tlperl/lib/Locale/Country.pm
new file mode 100644
index 00000000000..2ecd1305c0d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Country.pm
@@ -0,0 +1,550 @@
+#
+# Locale::Country - ISO codes for country identification (ISO 3166)
+#
+# $Id: Country.pm,v 2.7 2004/06/10 21:19:34 neilb Exp $
+#
+
+package Locale::Country;
+use strict;
+require 5.002;
+
+require Exporter;
+use Carp;
+use Locale::Constants;
+
+
+#-----------------------------------------------------------------------
+# Public Global Variables
+#-----------------------------------------------------------------------
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+@ISA = qw(Exporter);
+@EXPORT = qw(code2country country2code
+ all_country_codes all_country_names
+ country_code2code
+ LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 LOCALE_CODE_NUMERIC);
+
+#-----------------------------------------------------------------------
+# Private Global Variables
+#-----------------------------------------------------------------------
+my $CODES = [];
+my $COUNTRIES = [];
+
+
+#=======================================================================
+#
+# code2country ( CODE [, CODESET ] )
+#
+#=======================================================================
+sub code2country
+{
+ my $code = shift;
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+
+ return undef unless defined $code;
+
+ #-------------------------------------------------------------------
+ # Make sure the code is in the right form before we use it
+ # to look up the corresponding country.
+ # We have to sprintf because the codes are given as 3-digits,
+ # with leading 0's. Eg 052 for Barbados.
+ #-------------------------------------------------------------------
+ if ($codeset == LOCALE_CODE_NUMERIC)
+ {
+ return undef if ($code =~ /\D/);
+ $code = sprintf("%.3d", $code);
+ }
+ else
+ {
+ $code = lc($code);
+ }
+
+ if (exists $CODES->[$codeset]->{$code})
+ {
+ return $CODES->[$codeset]->{$code};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such country code!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# country2code ( NAME [, CODESET ] )
+#
+#=======================================================================
+sub country2code
+{
+ my $country = shift;
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+
+ return undef unless defined $country;
+ $country = lc($country);
+ if (exists $COUNTRIES->[$codeset]->{$country})
+ {
+ return $COUNTRIES->[$codeset]->{$country};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such country!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# country_code2code ( NAME [, CODESET ] )
+#
+#=======================================================================
+sub country_code2code
+{
+ (@_ == 3) or croak "country_code2code() takes 3 arguments!";
+
+ my $code = shift;
+ my $inset = shift;
+ my $outset = shift;
+ my $outcode;
+ my $country;
+
+
+ return undef if $inset == $outset;
+ $country = code2country($code, $inset);
+ return undef if not defined $country;
+ $outcode = country2code($country, $outset);
+ return $outcode;
+}
+
+
+#=======================================================================
+#
+# all_country_codes ( [ CODESET ] )
+#
+#=======================================================================
+sub all_country_codes
+{
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+ return keys %{ $CODES->[$codeset] };
+}
+
+
+#=======================================================================
+#
+# all_country_names ( [ CODESET ] )
+#
+#=======================================================================
+sub all_country_names
+{
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+ return values %{ $CODES->[$codeset] };
+}
+
+
+#=======================================================================
+#
+# alias_code ( ALIAS => CODE [ , CODESET ] )
+#
+# Add an alias for an existing code. If the CODESET isn't specified,
+# then we use the default (currently the alpha-2 codeset).
+#
+# Locale::Country::alias_code('uk' => 'gb');
+#
+#=======================================================================
+sub alias_code
+{
+ my $alias = shift;
+ my $real = shift;
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+ my $country;
+
+
+ if (not exists $CODES->[$codeset]->{$real})
+ {
+ carp "attempt to alias \"$alias\" to unknown country code \"$real\"\n";
+ return undef;
+ }
+ $country = $CODES->[$codeset]->{$real};
+ $CODES->[$codeset]->{$alias} = $country;
+ $COUNTRIES->[$codeset]->{"\L$country"} = $alias;
+
+ return $alias;
+}
+
+# old name of function for backwards compatibility
+*_alias_code = *alias_code;
+
+
+#=======================================================================
+#
+# rename_country
+#
+# change the official name for a country, eg:
+# gb => 'Great Britain'
+# rather than the standard 'United Kingdom'. The original is retained
+# as an alias, but the new name will be returned if you lookup the
+# name from code.
+#
+#=======================================================================
+sub rename_country
+{
+ my $code = shift;
+ my $new_name = shift;
+ my $codeset = @_ > 0 ? shift : _code2codeset($code);
+ my $country;
+ my $c;
+
+
+ if (not defined $codeset)
+ {
+ carp "rename_country(): unknown country code \"$code\"\n";
+ return 0;
+ }
+
+ $country = $CODES->[$codeset]->{$code};
+
+ foreach my $cset (LOCALE_CODE_ALPHA_2,
+ LOCALE_CODE_ALPHA_3,
+ LOCALE_CODE_NUMERIC)
+ {
+ if ($cset == $codeset)
+ {
+ $c = $code;
+ }
+ else
+ {
+ $c = country_code2code($code, $codeset, $cset);
+ }
+
+ $CODES->[$cset]->{$c} = $new_name;
+ $COUNTRIES->[$cset]->{"\L$new_name"} = $c;
+ }
+
+ return 1;
+}
+
+
+#=======================================================================
+#
+# _code2codeset
+#
+# given a country code in an unknown codeset, return the codeset
+# it is from, or undef.
+#
+#=======================================================================
+sub _code2codeset
+{
+ my $code = shift;
+
+
+ foreach my $codeset (LOCALE_CODE_ALPHA_2, LOCALE_CODE_ALPHA_3,
+ LOCALE_CODE_NUMERIC)
+ {
+ return $codeset if (exists $CODES->[$codeset]->{$code})
+ }
+
+ return undef;
+}
+
+
+#=======================================================================
+#
+# initialisation code - stuff the DATA into the ALPHA2 hash
+#
+#=======================================================================
+{
+ my ($alpha2, $alpha3, $numeric);
+ my ($country, @countries);
+ local $_;
+
+
+ while (<DATA>)
+ {
+ next unless /\S/;
+ chop;
+ ($alpha2, $alpha3, $numeric, @countries) = split(/:/, $_);
+
+ $CODES->[LOCALE_CODE_ALPHA_2]->{$alpha2} = $countries[0];
+ foreach $country (@countries)
+ {
+ $COUNTRIES->[LOCALE_CODE_ALPHA_2]->{"\L$country"} = $alpha2;
+ }
+
+ if ($alpha3)
+ {
+ $CODES->[LOCALE_CODE_ALPHA_3]->{$alpha3} = $countries[0];
+ foreach $country (@countries)
+ {
+ $COUNTRIES->[LOCALE_CODE_ALPHA_3]->{"\L$country"} = $alpha3;
+ }
+ }
+
+ if ($numeric)
+ {
+ $CODES->[LOCALE_CODE_NUMERIC]->{$numeric} = $countries[0];
+ foreach $country (@countries)
+ {
+ $COUNTRIES->[LOCALE_CODE_NUMERIC]->{"\L$country"} = $numeric;
+ }
+ }
+
+ }
+
+ close(DATA);
+}
+
+1;
+
+__DATA__
+ad:and:020:Andorra
+ae:are:784:United Arab Emirates
+af:afg:004:Afghanistan
+ag:atg:028:Antigua and Barbuda
+ai:aia:660:Anguilla
+al:alb:008:Albania
+am:arm:051:Armenia
+an:ant:530:Netherlands Antilles
+ao:ago:024:Angola
+aq:ata:010:Antarctica
+ar:arg:032:Argentina
+as:asm:016:American Samoa
+at:aut:040:Austria
+au:aus:036:Australia
+aw:abw:533:Aruba
+ax:ala:248:Aland Islands
+az:aze:031:Azerbaijan
+ba:bih:070:Bosnia and Herzegovina
+bb:brb:052:Barbados
+bd:bgd:050:Bangladesh
+be:bel:056:Belgium
+bf:bfa:854:Burkina Faso
+bg:bgr:100:Bulgaria
+bh:bhr:048:Bahrain
+bi:bdi:108:Burundi
+bj:ben:204:Benin
+bm:bmu:060:Bermuda
+bn:brn:096:Brunei Darussalam
+bo:bol:068:Bolivia
+br:bra:076:Brazil
+bs:bhs:044:Bahamas
+bt:btn:064:Bhutan
+bv:bvt:074:Bouvet Island
+bw:bwa:072:Botswana
+by:blr:112:Belarus
+bz:blz:084:Belize
+ca:can:124:Canada
+cc:cck:166:Cocos (Keeling) Islands
+cd:cod:180:Congo, The Democratic Republic of the:Zaire:Congo, Democratic Republic of the
+cf:caf:140:Central African Republic
+cg:cog:178:Congo:Congo, Republic of the
+ch:che:756:Switzerland
+ci:civ:384:Cote D'Ivoire
+ck:cok:184:Cook Islands
+cl:chl:152:Chile
+cm:cmr:120:Cameroon
+cn:chn:156:China
+co:col:170:Colombia
+cr:cri:188:Costa Rica
+cs:scg:891:Serbia and Montenegro:Yugoslavia
+cu:cub:192:Cuba
+cv:cpv:132:Cape Verde
+cx:cxr:162:Christmas Island
+cy:cyp:196:Cyprus
+cz:cze:203:Czech Republic
+de:deu:276:Germany
+dj:dji:262:Djibouti
+dk:dnk:208:Denmark
+dm:dma:212:Dominica
+do:dom:214:Dominican Republic
+dz:dza:012:Algeria
+ec:ecu:218:Ecuador
+ee:est:233:Estonia
+eg:egy:818:Egypt
+eh:esh:732:Western Sahara
+er:eri:232:Eritrea
+es:esp:724:Spain
+et:eth:231:Ethiopia
+fi:fin:246:Finland
+fj:fji:242:Fiji
+fk:flk:238:Falkland Islands (Malvinas):Falkland Islands (Islas Malvinas)
+fm:fsm:583:Micronesia, Federated States of
+fo:fro:234:Faroe Islands
+fr:fra:250:France
+fx:fxx:249:France, Metropolitan
+ga:gab:266:Gabon
+gb:gbr:826:United Kingdom:Great Britain
+gd:grd:308:Grenada
+ge:geo:268:Georgia
+gf:guf:254:French Guiana
+gh:gha:288:Ghana
+gi:gib:292:Gibraltar
+gl:grl:304:Greenland
+gm:gmb:270:Gambia
+gn:gin:324:Guinea
+gp:glp:312:Guadeloupe
+gq:gnq:226:Equatorial Guinea
+gr:grc:300:Greece
+gs:sgs:239:South Georgia and the South Sandwich Islands
+gt:gtm:320:Guatemala
+gu:gum:316:Guam
+gw:gnb:624:Guinea-Bissau
+gy:guy:328:Guyana
+hk:hkg:344:Hong Kong
+hm:hmd:334:Heard Island and McDonald Islands
+hn:hnd:340:Honduras
+hr:hrv:191:Croatia
+ht:hti:332:Haiti
+hu:hun:348:Hungary
+id:idn:360:Indonesia
+ie:irl:372:Ireland
+il:isr:376:Israel
+in:ind:356:India
+io:iot:086:British Indian Ocean Territory
+iq:irq:368:Iraq
+ir:irn:364:Iran, Islamic Republic of:Iran
+is:isl:352:Iceland
+it:ita:380:Italy
+jm:jam:388:Jamaica
+jo:jor:400:Jordan
+jp:jpn:392:Japan
+ke:ken:404:Kenya
+kg:kgz:417:Kyrgyzstan
+kh:khm:116:Cambodia
+ki:kir:296:Kiribati
+km:com:174:Comoros
+kn:kna:659:Saint Kitts and Nevis
+kp:prk:408:Korea, Democratic People's Republic of:Korea, North:North Korea
+kr:kor:410:Korea, Republic of:Korea, South:South Korea
+kw:kwt:414:Kuwait
+ky:cym:136:Cayman Islands
+kz:kaz:398:Kazakhstan:Kazakstan
+la:lao:418:Lao People's Democratic Republic
+lb:lbn:422:Lebanon
+lc:lca:662:Saint Lucia
+li:lie:438:Liechtenstein
+lk:lka:144:Sri Lanka
+lr:lbr:430:Liberia
+ls:lso:426:Lesotho
+lt:ltu:440:Lithuania
+lu:lux:442:Luxembourg
+lv:lva:428:Latvia
+ly:lby:434:Libyan Arab Jamahiriya:Libya
+ma:mar:504:Morocco
+mc:mco:492:Monaco
+md:mda:498:Moldova, Republic of:Moldova
+mg:mdg:450:Madagascar
+mh:mhl:584:Marshall Islands
+mk:mkd:807:Macedonia, the Former Yugoslav Republic of:Macedonia, Former Yugoslav Republic of:Macedonia
+ml:mli:466:Mali
+mm:mmr:104:Myanmar:Burma
+mn:mng:496:Mongolia
+mo:mac:446:Macao:Macau
+mp:mnp:580:Northern Mariana Islands
+mq:mtq:474:Martinique
+mr:mrt:478:Mauritania
+ms:msr:500:Montserrat
+mt:mlt:470:Malta
+mu:mus:480:Mauritius
+mv:mdv:462:Maldives
+mw:mwi:454:Malawi
+mx:mex:484:Mexico
+my:mys:458:Malaysia
+mz:moz:508:Mozambique
+na:nam:516:Namibia
+nc:ncl:540:New Caledonia
+ne:ner:562:Niger
+nf:nfk:574:Norfolk Island
+ng:nga:566:Nigeria
+ni:nic:558:Nicaragua
+nl:nld:528:Netherlands
+no:nor:578:Norway
+np:npl:524:Nepal
+nr:nru:520:Nauru
+nu:niu:570:Niue
+nz:nzl:554:New Zealand
+om:omn:512:Oman
+pa:pan:591:Panama
+pe:per:604:Peru
+pf:pyf:258:French Polynesia
+pg:png:598:Papua New Guinea
+ph:phl:608:Philippines
+pk:pak:586:Pakistan
+pl:pol:616:Poland
+pm:spm:666:Saint Pierre and Miquelon
+pn:pcn:612:Pitcairn:Pitcairn Island
+pr:pri:630:Puerto Rico
+ps:pse:275:Palestinian Territory, Occupied
+pt:prt:620:Portugal
+pw:plw:585:Palau
+py:pry:600:Paraguay
+qa:qat:634:Qatar
+re:reu:638:Reunion
+ro:rou:642:Romania
+ru:rus:643:Russian Federation:Russia
+rw:rwa:646:Rwanda
+sa:sau:682:Saudi Arabia
+sb:slb:090:Solomon Islands
+sc:syc:690:Seychelles
+sd:sdn:736:Sudan
+se:swe:752:Sweden
+sg:sgp:702:Singapore
+sh:shn:654:Saint Helena
+si:svn:705:Slovenia
+sj:sjm:744:Svalbard and Jan Mayen:Jan Mayen:Svalbard
+sk:svk:703:Slovakia
+sl:sle:694:Sierra Leone
+sm:smr:674:San Marino
+sn:sen:686:Senegal
+so:som:706:Somalia
+sr:sur:740:Suriname
+st:stp:678:Sao Tome and Principe
+sv:slv:222:El Salvador
+sy:syr:760:Syrian Arab Republic:Syria
+sz:swz:748:Swaziland
+tc:tca:796:Turks and Caicos Islands
+td:tcd:148:Chad
+tf:atf:260:French Southern Territories:French Southern and Antarctic Lands
+tg:tgo:768:Togo
+th:tha:764:Thailand
+tj:tjk:762:Tajikistan
+tk:tkl:772:Tokelau
+tm:tkm:795:Turkmenistan
+tn:tun:788:Tunisia
+to:ton:776:Tonga
+tl:tls:626:Timor-Leste:East Timor
+tr:tur:792:Turkey
+tt:tto:780:Trinidad and Tobago
+tv:tuv:798:Tuvalu
+tw:twn:158:Taiwan, Province of China:Taiwan
+tz:tza:834:Tanzania, United Republic of:Tanzania
+ua:ukr:804:Ukraine
+ug:uga:800:Uganda
+um:umi:581:United States Minor Outlying Islands
+us:usa:840:United States:USA:United States of America
+uy:ury:858:Uruguay
+uz:uzb:860:Uzbekistan
+va:vat:336:Holy See (Vatican City State):Holy See (Vatican City)
+vc:vct:670:Saint Vincent and the Grenadines
+ve:ven:862:Venezuela
+vg:vgb:092:Virgin Islands, British:British Virgin Islands
+vi:vir:850:Virgin Islands, U.S.
+vn:vnm:704:Vietnam
+vu:vut:548:Vanuatu
+wf:wlf:876:Wallis and Futuna
+ws:wsm:882:Samoa
+ye:yem:887:Yemen
+yt:myt:175:Mayotte
+za:zaf:710:South Africa
+zm:zmb:894:Zambia
+zw:zwe:716:Zimbabwe
diff --git a/Master/tlpkg/tlperl/lib/Locale/Country.pod b/Master/tlpkg/tlperl/lib/Locale/Country.pod
new file mode 100644
index 00000000000..b13cd22a4a7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Country.pod
@@ -0,0 +1,306 @@
+
+=head1 NAME
+
+Locale::Country - ISO codes for country identification (ISO 3166)
+
+=head1 SYNOPSIS
+
+ use Locale::Country;
+
+ $country = code2country('jp'); # $country gets 'Japan'
+ $code = country2code('Norway'); # $code gets 'no'
+
+ @codes = all_country_codes();
+ @names = all_country_names();
+
+ # semi-private routines
+ Locale::Country::alias_code('uk' => 'gb');
+ Locale::Country::rename_country('gb' => 'Great Britain');
+
+
+=head1 DESCRIPTION
+
+The C<Locale::Country> module provides access to the ISO
+codes for identifying countries, as defined in ISO 3166-1.
+You can either access the codes via the L<conversion routines>
+(described below), or with the two functions which return lists
+of all country codes or all country names.
+
+There are three different code sets you can use for identifying
+countries:
+
+=over 4
+
+=item B<alpha-2>
+
+Two letter codes, such as 'tv' for Tuvalu.
+This code set is identified with the symbol C<LOCALE_CODE_ALPHA_2>.
+
+=item B<alpha-3>
+
+Three letter codes, such as 'brb' for Barbados.
+This code set is identified with the symbol C<LOCALE_CODE_ALPHA_3>.
+
+=item B<numeric>
+
+Numeric codes, such as 064 for Bhutan.
+This code set is identified with the symbol C<LOCALE_CODE_NUMERIC>.
+
+=back
+
+All of the routines take an optional additional argument
+which specifies the code set to use.
+If not specified, it defaults to the two-letter codes.
+This is partly for backwards compatibility (previous versions
+of this module only supported the alpha-2 codes), and
+partly because they are the most widely used codes.
+
+The alpha-2 and alpha-3 codes are not case-dependent,
+so you can use 'BO', 'Bo', 'bO' or 'bo' for Bolivia.
+When a code is returned by one of the functions in
+this module, it will always be lower-case.
+
+As of version 2.00, Locale::Country supports variant
+names for countries. So, for example, the country code for "United States"
+is "us", so country2code('United States') returns 'us'.
+Now the following will also return 'us':
+
+ country2code('United States of America')
+ country2code('USA')
+
+
+=head1 CONVERSION ROUTINES
+
+There are three conversion routines: C<code2country()>, C<country2code()>,
+and C<country_code2code()>.
+
+=over 4
+
+=item code2country( CODE, [ CODESET ] )
+
+This function takes a country code and returns a string
+which contains the name of the country identified.
+If the code is not a valid country code, as defined by ISO 3166,
+then C<undef> will be returned:
+
+ $country = code2country('fi');
+
+=item country2code( STRING, [ CODESET ] )
+
+This function takes a country name and returns the corresponding
+country code, if such exists.
+If the argument could not be identified as a country name,
+then C<undef> will be returned:
+
+ $code = country2code('Norway', LOCALE_CODE_ALPHA_3);
+ # $code will now be 'nor'
+
+The case of the country name is not important.
+See the section L<KNOWN BUGS AND LIMITATIONS> below.
+
+=item country_code2code( CODE, CODESET, CODESET )
+
+This function takes a country code from one code set,
+and returns the corresponding code from another code set.
+
+ $alpha2 = country_code2code('fin',
+ LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_2);
+ # $alpha2 will now be 'fi'
+
+If the code passed is not a valid country code in
+the first code set, or if there isn't a code for the
+corresponding country in the second code set,
+then C<undef> will be returned.
+
+=back
+
+
+=head1 QUERY ROUTINES
+
+There are two function which can be used to obtain a list of all codes,
+or all country names:
+
+=over 4
+
+=item C<all_country_codes( [ CODESET ] )>
+
+Returns a list of all two-letter country codes.
+The codes are guaranteed to be all lower-case,
+and not in any particular order.
+
+=item C<all_country_names( [ CODESET ] )>
+
+Returns a list of all country names for which there is a corresponding
+country code in the specified code set.
+The names are capitalised, and not returned in any particular order.
+
+Not all countries have alpha-3 and numeric codes -
+some just have an alpha-2 code,
+so you'll get a different number of countries
+depending on which code set you specify.
+
+=back
+
+
+=head1 SEMI-PRIVATE ROUTINES
+
+Locale::Country provides two semi-private routines for modifying
+the internal data.
+Given their status, they aren't exported by default,
+and so need to be called by prefixing the function name with the
+package name.
+
+=head2 alias_code
+
+Define a new code as an alias for an existing code:
+
+ Locale::Country::alias_code( ALIAS => CODE [, CODESET ] )
+
+This feature was added as a mechanism for handling
+a "uk" code. The ISO standard says that the two-letter code for
+"United Kingdom" is "gb", whereas domain names are all .uk.
+
+By default the module does not understand "uk", since it is implementing
+an ISO standard. If you would like 'uk' to work as the two-letter
+code for United Kingdom, use the following:
+
+ Locale::Country::alias_code('uk' => 'gb');
+
+With this code, both "uk" and "gb" are valid codes for United Kingdom,
+with the reverse lookup returning "uk" rather than the usual "gb".
+
+B<Note:> this function was previously called _alias_code,
+but the leading underscore has been dropped.
+The old name will be supported for all 2.X releases for
+backwards compatibility.
+
+=head2 rename_country
+
+If the official country name just isn't good enough for you,
+you can rename a country. For example, the official country
+name for code 'gb' is 'United Kingdom'.
+If you want to change that, you might call:
+
+ Locale::Country::rename_country('gb' => 'Great Britain');
+
+This means that calling code2country('gb') will now return
+'Great Britain' instead of 'United Kingdom'.
+The original country name is retained as an alias,
+so for the above example, country2code('United Kingdom')
+will still return 'gb'.
+
+
+=head1 EXAMPLES
+
+The following example illustrates use of the C<code2country()> function.
+The user is prompted for a country code, and then told the corresponding
+country name:
+
+ $| = 1; # turn off buffering
+
+ print "Enter country code: ";
+ chop($code = <STDIN>);
+ $country = code2country($code, LOCALE_CODE_ALPHA_2);
+ if (defined $country)
+ {
+ print "$code = $country\n";
+ }
+ else
+ {
+ print "'$code' is not a valid country code!\n";
+ }
+
+=head1 DOMAIN NAMES
+
+Most top-level domain names are based on these codes,
+but there are certain codes which aren't.
+If you are using this module to identify country from hostname,
+your best bet is to preprocess the country code.
+
+For example, B<edu>, B<com>, B<gov> and friends would map to B<us>;
+B<uk> would map to B<gb>. Any others?
+
+=head1 KNOWN BUGS AND LIMITATIONS
+
+=over 4
+
+=item *
+
+When using C<country2code()>, the country name must currently appear
+exactly as it does in the source of the module. The module now supports
+a small number of variants.
+
+Possible extensions to this are: an interface for getting at the
+list of variant names, and regular expression matches.
+
+=item *
+
+In the current implementation, all data is read in when the
+module is loaded, and then held in memory.
+A lazy implementation would be more memory friendly.
+
+=item *
+
+Support for country names in different languages.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Locale::Language
+
+ISO two letter codes for identification of language (ISO 639).
+
+=item Locale::Script
+
+ISO codes for identification of scripts (ISO 15924).
+
+=item Locale::Currency
+
+ISO three letter codes for identification of currencies
+and funds (ISO 4217).
+
+=item Locale::SubCountry
+
+ISO codes for country sub-divisions (states, counties, provinces, etc),
+as defined in ISO 3166-2.
+This module is not part of the Locale-Codes distribution,
+but is available from CPAN in CPAN/modules/by-module/Locale/
+
+=item ISO 3166-1
+
+The ISO standard which defines these codes.
+
+=item http://www.iso.org/iso/en/prods-services/iso3166ma/index.html
+
+Official home page for the ISO 3166 maintenance agency.
+
+=item http://www.egt.ie/standards/iso3166/iso3166-1-en.html
+
+Another useful, but not official, home page.
+
+=item http://www.cia.gov/cia/publications/factbook/docs/app-d-1.html
+
+An appendix in the CIA world fact book which lists country codes
+as defined by ISO 3166, FIPS 10-4, and internet domain names.
+
+=back
+
+
+=head1 AUTHOR
+
+Neil Bowers E<lt>neil@bowers.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002-2004, Neil Bowers.
+
+Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Currency.pm b/Master/tlpkg/tlperl/lib/Locale/Currency.pm
new file mode 100644
index 00000000000..13cd0482ba7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Currency.pm
@@ -0,0 +1,356 @@
+#
+# Locale::Currency - ISO three letter codes for currency identification
+# (ISO 4217)
+#
+# $Id: Currency.pm,v 2.7 2004/06/10 21:19:34 neilb Exp $
+#
+
+package Locale::Currency;
+use strict;
+require 5.002;
+
+require Exporter;
+
+#-----------------------------------------------------------------------
+# Public Global Variables
+#-----------------------------------------------------------------------
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+@ISA = qw(Exporter);
+@EXPORT = qw(&code2currency &currency2code
+ &all_currency_codes &all_currency_names );
+
+#-----------------------------------------------------------------------
+# Private Global Variables
+#-----------------------------------------------------------------------
+my %CODES = ();
+my %CURRENCIES = ();
+
+
+#=======================================================================
+#
+# code2currency( CODE )
+#
+#=======================================================================
+sub code2currency
+{
+ my $code = shift;
+
+
+ return undef unless defined $code;
+ $code = lc($code);
+ if (exists $CODES{$code})
+ {
+ return $CODES{$code};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such currency code!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# currency2code ( CURRENCY )
+#
+#=======================================================================
+sub currency2code
+{
+ my $curr = shift;
+
+
+ return undef unless defined $curr;
+ $curr = lc($curr);
+ if (exists $CURRENCIES{$curr})
+ {
+ return $CURRENCIES{$curr};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such currency!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# all_currency_codes()
+#
+#=======================================================================
+sub all_currency_codes
+{
+ return keys %CODES;
+}
+
+
+#=======================================================================
+#
+# all_currency_names()
+#
+#=======================================================================
+sub all_currency_names
+{
+ return values %CODES;
+}
+
+
+#=======================================================================
+# initialisation code - stuff the DATA into the CODES hash
+#=======================================================================
+{
+ my $code;
+ my $currency;
+ local $_;
+
+
+ while (<DATA>)
+ {
+ next unless /\S/;
+ chop;
+ ($code, $currency) = split(/:/, $_, 2);
+ $CODES{$code} = $currency;
+ $CURRENCIES{"\L$currency"} = $code;
+ }
+
+ close(DATA);
+}
+
+1;
+
+__DATA__
+adp:Andorran Peseta
+aed:UAE Dirham
+afa:Afghani
+all:Lek
+amd:Armenian Dram
+ang:Netherlands Antillean Guilder
+aoa:Kwanza
+aon:New Kwanza
+aor:Kwanza Reajustado
+ars:Argentine Peso
+ats:Schilling
+aud:Australian Dollar
+awg:Aruban Guilder
+azm:Azerbaijanian Manat
+
+bam:Convertible Marks
+bbd:Barbados Dollar
+bdt:Taka
+bef:Belgian Franc
+bgl:Lev
+bgn:Bulgarian Lev
+bhd:Bahraini Dinar
+bhd:Dinar
+bif:Burundi Franc
+bmd:Bermudian Dollar
+bnd:Brunei Dollar
+bob:Boliviano
+bov:MVDol
+brl:Brazilian Real
+bsd:Bahamian Dollar
+btn:Ngultrum
+bwp:Pula
+byb:Belarussian Ruble
+byr:Belarussian Ruble
+bzd:Belize Dollar
+
+cad:Canadian Dollar
+cdf:Franc Congolais
+chf:Swiss Franc
+clf:Unidades de Formento
+clp:Chilean Peso
+cny:Yuan Renminbi
+cop:Colombian Peso
+crc:Costa Rican Colon
+cup:Cuban Peso
+cve:Cape Verde Escudo
+cyp:Cyprus Pound
+czk:Czech Koruna
+
+dem:German Mark
+djf:Djibouti Franc
+dkk:Danish Krone
+dop:Dominican Peso
+dzd:Algerian Dinar
+
+ecs:Sucre
+ecv:Unidad de Valor Constante (UVC)
+eek:Kroon
+egp:Egyptian Pound
+ern:Nakfa
+esp:Spanish Peseta
+etb:Ethiopian Birr
+eur:Euro
+
+fim:Markka
+fjd:Fiji Dollar
+fkp:Falkland Islands Pound
+frf:French Franc
+
+gbp:Pound Sterling
+gel:Lari
+ghc:Cedi
+gip:Gibraltar Pound
+gmd:Dalasi
+gnf:Guinea Franc
+grd:Drachma
+gtq:Quetzal
+gwp:Guinea-Bissau Peso
+gyd:Guyana Dollar
+
+hkd:Hong Kong Dollar
+hnl:Lempira
+hrk:Kuna
+htg:Gourde
+huf:Forint
+
+idr:Rupiah
+iep:Irish Pound
+ils:Shekel
+inr:Indian Rupee
+iqd:Iraqi Dinar
+irr:Iranian Rial
+isk:Iceland Krona
+itl:Italian Lira
+
+jmd:Jamaican Dollar
+jod:Jordanian Dinar
+jpy:Yen
+
+kes:Kenyan Shilling
+kgs:Som
+khr:Riel
+kmf:Comoro Franc
+kpw:North Korean Won
+krw:Won
+kwd:Kuwaiti Dinar
+kyd:Cayman Islands Dollar
+kzt:Tenge
+
+lak:Kip
+lbp:Lebanese Pound
+lkr:Sri Lanka Rupee
+lrd:Liberian Dollar
+lsl:Loti
+ltl:Lithuanian Litas
+luf:Luxembourg Franc
+lvl:Latvian Lats
+lyd:Libyan Dinar
+
+mad:Moroccan Dirham
+mdl:Moldovan Leu
+mgf:Malagasy Franc
+mkd:Denar
+mmk:Kyat
+mnt:Tugrik
+mop:Pataca
+mro:Ouguiya
+mtl:Maltese Lira
+mur:Mauritius Rupee
+mvr:Rufiyaa
+mwk:Kwacha
+mxn:Mexican Nuevo Peso
+myr:Malaysian Ringgit
+mzm:Metical
+
+nad:Namibia Dollar
+ngn:Naira
+nio:Cordoba Oro
+nlg:Netherlands Guilder
+nok:Norwegian Krone
+npr:Nepalese Rupee
+nzd:New Zealand Dollar
+
+omr:Rial Omani
+
+pab:Balboa
+pen:Nuevo Sol
+pgk:Kina
+php:Philippine Peso
+pkr:Pakistan Rupee
+pln:Zloty
+pte:Portuguese Escudo
+pyg:Guarani
+
+qar:Qatari Rial
+
+rol:Leu
+rub:Russian Ruble
+rur:Russian Ruble
+rwf:Rwanda Franc
+
+sar:Saudi Riyal
+sbd:Solomon Islands Dollar
+scr:Seychelles Rupee
+sdd:Sudanese Dinar
+sek:Swedish Krona
+sgd:Singapore Dollar
+shp:St. Helena Pound
+sit:Tolar
+skk:Slovak Koruna
+sll:Leone
+sos:Somali Shilling
+srg:Surinam Guilder
+std:Dobra
+svc:El Salvador Colon
+syp:Syrian Pound
+szl:Lilangeni
+
+thb:Baht
+tjr:Tajik Ruble
+tmm:Manat
+tnd:Tunisian Dollar
+top:Pa'anga
+tpe:Timor Escudo
+trl:Turkish Lira
+ttd:Trinidad and Tobago Dollar
+twd:New Taiwan Dollar
+tzs:Tanzanian Shilling
+
+uah:Hryvnia
+uak:Karbovanets
+ugx:Uganda Shilling
+usd:US Dollar
+usn:US Dollar (Next day)
+uss:US Dollar (Same day)
+uyu:Peso Uruguayo
+uzs:Uzbekistan Sum
+
+veb:Bolivar
+vnd:Dong
+vuv:Vatu
+
+wst:Tala
+
+xaf:CFA Franc BEAC
+xag:Silver
+xau:Gold
+xba:European Composite Unit
+xbb:European Monetary Unit
+xbc:European Unit of Account 9
+xb5:European Unit of Account 17
+xcd:East Caribbean Dollar
+xdr:SDR
+xeu:ECU (until 1998-12-31)
+xfu:UIC-Franc
+xfo:Gold-Franc
+xof:CFA Franc BCEAO
+xpd:Palladium
+xpf:CFP Franc
+xpt:Platinum
+
+yer:Yemeni Rial
+yum:New Dinar
+
+zal:Financial Rand
+zar:Rand
+zmk:Kwacha
+zrn:New Zaire
+zwd:Zimbabwe Dollar
diff --git a/Master/tlpkg/tlperl/lib/Locale/Currency.pod b/Master/tlpkg/tlperl/lib/Locale/Currency.pod
new file mode 100644
index 00000000000..dce32612949
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Currency.pod
@@ -0,0 +1,191 @@
+
+=head1 NAME
+
+Locale::Currency - ISO three letter codes for currency identification (ISO 4217)
+
+=head1 SYNOPSIS
+
+ use Locale::Currency;
+
+ $curr = code2currency('usd'); # $curr gets 'US Dollar'
+ $code = currency2code('Euro'); # $code gets 'eur'
+
+ @codes = all_currency_codes();
+ @names = all_currency_names();
+
+
+=head1 DESCRIPTION
+
+The C<Locale::Currency> module provides access to the ISO three-letter
+codes for identifying currencies and funds, as defined in ISO 4217.
+You can either access the codes via the L<conversion routines>
+(described below),
+or with the two functions which return lists of all currency codes or
+all currency names.
+
+There are two special codes defined by the standard which aren't
+understood by this module:
+
+=over 4
+
+=item XTS
+
+Specifically reserved for testing purposes.
+
+=item XXX
+
+For transactions where no currency is involved.
+
+=back
+
+
+=head1 CONVERSION ROUTINES
+
+There are two conversion routines: C<code2currency()> and C<currency2code()>.
+
+=over 4
+
+=item code2currency()
+
+This function takes a three letter currency code and returns a string
+which contains the name of the currency identified. If the code is
+not a valid currency code, as defined by ISO 4217, then C<undef>
+will be returned.
+
+ $curr = code2currency($code);
+
+=item currency2code()
+
+This function takes a currency name and returns the corresponding
+three letter currency code, if such exists.
+If the argument could not be identified as a currency name,
+then C<undef> will be returned.
+
+ $code = currency2code('French Franc');
+
+The case of the currency name is not important.
+See the section L<KNOWN BUGS AND LIMITATIONS> below.
+
+=back
+
+
+=head1 QUERY ROUTINES
+
+There are two function which can be used to obtain a list of all
+currency codes, or all currency names:
+
+=over 4
+
+=item C<all_currency_codes()>
+
+Returns a list of all three-letter currency codes.
+The codes are guaranteed to be all lower-case,
+and not in any particular order.
+
+=item C<all_currency_names()>
+
+Returns a list of all currency names for which there is a corresponding
+three-letter currency code. The names are capitalised, and not returned
+in any particular order.
+
+=back
+
+
+=head1 EXAMPLES
+
+The following example illustrates use of the C<code2currency()> function.
+The user is prompted for a currency code, and then told the corresponding
+currency name:
+
+ $| = 1; # turn off buffering
+
+ print "Enter currency code: ";
+ chop($code = <STDIN>);
+ $curr = code2currency($code);
+ if (defined $curr)
+ {
+ print "$code = $curr\n";
+ }
+ else
+ {
+ print "'$code' is not a valid currency code!\n";
+ }
+
+=head1 KNOWN BUGS AND LIMITATIONS
+
+=over 4
+
+=item *
+
+In the current implementation, all data is read in when the
+module is loaded, and then held in memory.
+A lazy implementation would be more memory friendly.
+
+=item *
+
+This module also includes the special codes which are
+not for a currency, such as Gold, Platinum, etc.
+This might cause a problem if you're using this module
+to display a list of currencies.
+Let Neil know if this does cause a problem, and we can
+do something about it.
+
+=item *
+
+ISO 4217 also defines a numeric code for each currency.
+Currency codes are not currently supported by this module,
+in the same way Locale::Country supports multiple codesets.
+
+=item *
+
+There are three cases where there is more than one
+code for the same currency name.
+Kwacha has two codes: mwk for Malawi, and zmk for Zambia.
+The Russian Ruble has two codes: rub and rur.
+The Belarussian Ruble has two codes: byr and byb.
+The currency2code() function only returns one code, so
+you might not get back the code you expected.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Locale::Country
+
+ISO codes for identification of country (ISO 3166).
+
+=item Locale::Script
+
+ISO codes for identification of written scripts (ISO 15924).
+
+=item ISO 4217:1995
+
+Code for the representation of currencies and funds.
+
+=item http://www.bsi-global.com/iso4217currency
+
+Official web page for the ISO 4217 maintenance agency.
+This has the latest list of codes, in MS Word format. Boo.
+
+=back
+
+=head1 AUTHOR
+
+Michael Hennecke E<lt>hennecke@rz.uni-karlsruhe.deE<gt>
+and
+Neil Bowers E<lt>neil@bowers.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002-2004, Neil Bowers.
+
+Copyright (c) 2001 Michael Hennecke and
+Canon Research Centre Europe (CRE).
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Language.pm b/Master/tlpkg/tlperl/lib/Locale/Language.pm
new file mode 100644
index 00000000000..e8454c39b4a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Language.pm
@@ -0,0 +1,315 @@
+#
+# Locale::Language - ISO two letter codes for language identification (ISO 639)
+#
+# $Id: Language.pm,v 2.7 2004/06/10 21:19:34 neilb Exp $
+#
+
+package Locale::Language;
+use strict;
+require 5.002;
+
+require Exporter;
+
+#-----------------------------------------------------------------------
+# Public Global Variables
+#-----------------------------------------------------------------------
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+@ISA = qw(Exporter);
+@EXPORT = qw(&code2language &language2code
+ &all_language_codes &all_language_names );
+
+#-----------------------------------------------------------------------
+# Private Global Variables
+#-----------------------------------------------------------------------
+my %CODES = ();
+my %LANGUAGES = ();
+
+
+#=======================================================================
+#
+# code2language ( CODE )
+#
+#=======================================================================
+sub code2language
+{
+ my $code = shift;
+
+
+ return undef unless defined $code;
+ $code = lc($code);
+ if (exists $CODES{$code})
+ {
+ return $CODES{$code};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such language code!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# language2code ( LANGUAGE )
+#
+#=======================================================================
+sub language2code
+{
+ my $lang = shift;
+
+
+ return undef unless defined $lang;
+ $lang = lc($lang);
+ if (exists $LANGUAGES{$lang})
+ {
+ return $LANGUAGES{$lang};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such language!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# all_language_codes()
+#
+#=======================================================================
+sub all_language_codes
+{
+ return keys %CODES;
+}
+
+
+#=======================================================================
+#
+# all_language_names()
+#
+#=======================================================================
+sub all_language_names
+{
+ return values %CODES;
+}
+
+
+#=======================================================================
+# initialisation code - stuff the DATA into the CODES hash
+#=======================================================================
+{
+ my $code;
+ my $language;
+ local $_;
+
+
+ while (<DATA>)
+ {
+ next unless /\S/;
+ chop;
+ ($code, $language) = split(/:/, $_, 2);
+ $CODES{$code} = $language;
+ $LANGUAGES{"\L$language"} = $code;
+ }
+
+ close(DATA);
+}
+
+1;
+
+__DATA__
+aa:Afar
+ab:Abkhazian
+ae:Avestan
+af:Afrikaans
+am:Amharic
+ar:Arabic
+as:Assamese
+ay:Aymara
+az:Azerbaijani
+
+ba:Bashkir
+be:Belarusian
+bg:Bulgarian
+bh:Bihari
+bi:Bislama
+bn:Bengali
+bo:Tibetan
+br:Breton
+bs:Bosnian
+
+ca:Catalan
+ce:Chechen
+ch:Chamorro
+co:Corsican
+cs:Czech
+cu:Church Slavic
+cv:Chuvash
+cy:Welsh
+
+da:Danish
+de:German
+dz:Dzongkha
+
+el:Greek
+en:English
+eo:Esperanto
+es:Spanish
+et:Estonian
+eu:Basque
+
+fa:Persian
+fi:Finnish
+fj:Fijian
+fo:Faeroese
+fr:French
+fy:Frisian
+
+ga:Irish
+gd:Gaelic (Scots)
+gl:Gallegan
+gn:Guarani
+gu:Gujarati
+gv:Manx
+
+ha:Hausa
+he:Hebrew
+hi:Hindi
+ho:Hiri Motu
+hr:Croatian
+hu:Hungarian
+hy:Armenian
+hz:Herero
+
+ia:Interlingua
+id:Indonesian
+ie:Interlingue
+ik:Inupiaq
+is:Icelandic
+it:Italian
+iu:Inuktitut
+
+ja:Japanese
+jw:Javanese
+
+ka:Georgian
+ki:Kikuyu
+kj:Kuanyama
+kk:Kazakh
+kl:Kalaallisut
+km:Khmer
+kn:Kannada
+ko:Korean
+ks:Kashmiri
+ku:Kurdish
+kv:Komi
+kw:Cornish
+ky:Kirghiz
+
+la:Latin
+lb:Letzeburgesch
+ln:Lingala
+lo:Lao
+lt:Lithuanian
+lv:Latvian
+
+mg:Malagasy
+mh:Marshall
+mi:Maori
+mk:Macedonian
+ml:Malayalam
+mn:Mongolian
+mo:Moldavian
+mr:Marathi
+ms:Malay
+mt:Maltese
+my:Burmese
+
+na:Nauru
+nb:Norwegian Bokmal
+nd:Ndebele, North
+ne:Nepali
+ng:Ndonga
+nl:Dutch
+nn:Norwegian Nynorsk
+no:Norwegian
+nr:Ndebele, South
+nv:Navajo
+ny:Chichewa; Nyanja
+
+oc:Occitan (post 1500)
+om:Oromo
+or:Oriya
+os:Ossetian; Ossetic
+
+pa:Panjabi
+pi:Pali
+pl:Polish
+ps:Pushto
+pt:Portuguese
+
+qu:Quechua
+
+rm:Rhaeto-Romance
+rn:Rundi
+ro:Romanian
+ru:Russian
+rw:Kinyarwanda
+
+sa:Sanskrit
+sc:Sardinian
+sd:Sindhi
+se:Sami
+sg:Sango
+si:Sinhalese
+sk:Slovak
+sl:Slovenian
+sm:Samoan
+sn:Shona
+so:Somali
+sq:Albanian
+sr:Serbian
+ss:Swati
+st:Sotho
+su:Sundanese
+sv:Swedish
+sw:Swahili
+
+ta:Tamil
+te:Telugu
+tg:Tajik
+th:Thai
+ti:Tigrinya
+tk:Turkmen
+tl:Tagalog
+tn:Tswana
+to:Tonga
+tr:Turkish
+ts:Tsonga
+tt:Tatar
+tw:Twi
+
+ug:Uighur
+uk:Ukrainian
+ur:Urdu
+uz:Uzbek
+
+vi:Vietnamese
+vo:Volapuk
+
+wo:Wolof
+
+xh:Xhosa
+
+yi:Yiddish
+yo:Yoruba
+
+za:Zhuang
+zh:Chinese
+zu:Zulu
diff --git a/Master/tlpkg/tlperl/lib/Locale/Language.pod b/Master/tlpkg/tlperl/lib/Locale/Language.pod
new file mode 100644
index 00000000000..ce7b378e5d9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Language.pod
@@ -0,0 +1,158 @@
+
+=head1 NAME
+
+Locale::Language - ISO two letter codes for language identification (ISO 639)
+
+=head1 SYNOPSIS
+
+ use Locale::Language;
+
+ $lang = code2language('en'); # $lang gets 'English'
+ $code = language2code('French'); # $code gets 'fr'
+
+ @codes = all_language_codes();
+ @names = all_language_names();
+
+
+=head1 DESCRIPTION
+
+The C<Locale::Language> module provides access to the ISO two-letter
+codes for identifying languages, as defined in ISO 639. You can either
+access the codes via the L<conversion routines> (described below),
+or via the two functions which return lists of all language codes or
+all language names.
+
+
+=head1 CONVERSION ROUTINES
+
+There are two conversion routines: C<code2language()> and C<language2code()>.
+
+=over 4
+
+=item code2language()
+
+This function takes a two letter language code and returns a string
+which contains the name of the language identified. If the code is
+not a valid language code, as defined by ISO 639, then C<undef>
+will be returned.
+
+ $lang = code2language($code);
+
+=item language2code()
+
+This function takes a language name and returns the corresponding
+two letter language code, if such exists.
+If the argument could not be identified as a language name,
+then C<undef> will be returned.
+
+ $code = language2code('French');
+
+The case of the language name is not important.
+See the section L<KNOWN BUGS AND LIMITATIONS> below.
+
+=back
+
+
+=head1 QUERY ROUTINES
+
+There are two function which can be used to obtain a list of all
+language codes, or all language names:
+
+=over 4
+
+=item C<all_language_codes()>
+
+Returns a list of all two-letter language codes.
+The codes are guaranteed to be all lower-case,
+and not in any particular order.
+
+=item C<all_language_names()>
+
+Returns a list of all language names for which there is a corresponding
+two-letter language code. The names are capitalised, and not returned
+in any particular order.
+
+=back
+
+
+=head1 EXAMPLES
+
+The following example illustrates use of the C<code2language()> function.
+The user is prompted for a language code, and then told the corresponding
+language name:
+
+ $| = 1; # turn off buffering
+
+ print "Enter language code: ";
+ chop($code = <STDIN>);
+ $lang = code2language($code);
+ if (defined $lang)
+ {
+ print "$code = $lang\n";
+ }
+ else
+ {
+ print "'$code' is not a valid language code!\n";
+ }
+
+=head1 KNOWN BUGS AND LIMITATIONS
+
+=over 4
+
+=item *
+
+In the current implementation, all data is read in when the
+module is loaded, and then held in memory.
+A lazy implementation would be more memory friendly.
+
+=item *
+
+Currently just supports the two letter language codes -
+there are also three-letter codes, and numbers.
+Would these be of any use to anyone?
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Locale::Country
+
+ISO codes for identification of country (ISO 3166).
+Supports 2-letter, 3-letter, and numeric country codes.
+
+=item Locale::Script
+
+ISO codes for identification of written scripts (ISO 15924).
+
+=item Locale::Currency
+
+ISO three letter codes for identification of currencies and funds (ISO 4217).
+
+=item ISO 639:1988 (E/F)
+
+Code for the representation of names of languages.
+
+=item http://lcweb.loc.gov/standards/iso639-2/langhome.html
+
+Home page for ISO 639-2.
+
+=back
+
+
+=head1 AUTHOR
+
+Neil Bowers E<lt>neil@bowers.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002-2004, Neil Bowers.
+
+Copyright (c) 1997-2001 Canon Research Centre Europe (CRE).
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext.pm b/Master/tlpkg/tlperl/lib/Locale/Maketext.pm
new file mode 100644
index 00000000000..1bfbbc9bba4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext.pm
@@ -0,0 +1,456 @@
+package Locale::Maketext;
+use strict;
+use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
+$USE_LITERALS $MATCH_SUPERS_TIGHTLY);
+use Carp ();
+use I18N::LangTags 0.30 ();
+
+#--------------------------------------------------------------------------
+
+BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
+# define the constant 'DEBUG' at compile-time
+
+$VERSION = '1.14';
+@ISA = ();
+
+$MATCH_SUPERS = 1;
+$MATCH_SUPERS_TIGHTLY = 1;
+$USING_LANGUAGE_TAGS = 1;
+# Turning this off is somewhat of a security risk in that little or no
+# checking will be done on the legality of tokens passed to the
+# eval("use $module_name") in _try_use. If you turn this off, you have
+# to do your own taint checking.
+
+$USE_LITERALS = 1 unless defined $USE_LITERALS;
+# a hint for compiling bracket-notation things.
+
+my %isa_scan = ();
+
+###########################################################################
+
+sub quant {
+ my($handle, $num, @forms) = @_;
+
+ return $num if @forms == 0; # what should this mean?
+ return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
+
+ # Normal case:
+ # Note that the formatting of $num is preserved.
+ return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
+ # Most human languages put the number phrase before the qualified phrase.
+}
+
+
+sub numerate {
+ # return this lexical item in a form appropriate to this number
+ my($handle, $num, @forms) = @_;
+ my $s = ($num == 1);
+
+ return '' unless @forms;
+ if(@forms == 1) { # only the headword form specified
+ return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
+ }
+ else { # sing and plural were specified
+ return $s ? $forms[0] : $forms[1];
+ }
+}
+
+#--------------------------------------------------------------------------
+
+sub numf {
+ my($handle, $num) = @_[0,1];
+ if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
+ $num += 0; # Just use normal integer stringification.
+ # Specifically, don't let %G turn ten million into 1E+007
+ }
+ else {
+ $num = CORE::sprintf('%G', $num);
+ # "CORE::" is there to avoid confusion with the above sub sprintf.
+ }
+ while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
+ # The initial \d+ gobbles as many digits as it can, and then we
+ # backtrack so it un-eats the rightmost three, and then we
+ # insert the comma there.
+
+ $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
+ # This is just a lame hack instead of using Number::Format
+ return $num;
+}
+
+sub sprintf {
+ no integer;
+ my($handle, $format, @params) = @_;
+ return CORE::sprintf($format, @params);
+ # "CORE::" is there to avoid confusion with myself!
+}
+
+#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+
+use integer; # vroom vroom... applies to the whole rest of the module
+
+sub language_tag {
+ my $it = ref($_[0]) || $_[0];
+ return undef unless $it =~ m/([^':]+)(?:::)?$/s;
+ $it = lc($1);
+ $it =~ tr<_><->;
+ return $it;
+}
+
+sub encoding {
+ my $it = $_[0];
+ return(
+ (ref($it) && $it->{'encoding'})
+ || 'iso-8859-1' # Latin-1
+ );
+}
+
+#--------------------------------------------------------------------------
+
+sub fallback_languages { return('i-default', 'en', 'en-US') }
+
+sub fallback_language_classes { return () }
+
+#--------------------------------------------------------------------------
+
+sub fail_with { # an actual attribute method!
+ my($handle, @params) = @_;
+ return unless ref($handle);
+ $handle->{'fail'} = $params[0] if @params;
+ return $handle->{'fail'};
+}
+
+#--------------------------------------------------------------------------
+
+sub failure_handler_auto {
+ # Meant to be used like:
+ # $handle->fail_with('failure_handler_auto')
+
+ my $handle = shift;
+ my $phrase = shift;
+
+ $handle->{'failure_lex'} ||= {};
+ my $lex = $handle->{'failure_lex'};
+
+ my $value;
+ $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
+
+ # Dumbly copied from sub maketext:
+ return ${$value} if ref($value) eq 'SCALAR';
+ return $value if ref($value) ne 'CODE';
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ {\n in bracket code [compiled line $1],}s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ }
+ else {
+ return $value;
+ }
+}
+
+#==========================================================================
+
+sub new {
+ # Nothing fancy!
+ my $class = ref($_[0]) || $_[0];
+ my $handle = bless {}, $class;
+ $handle->init;
+ return $handle;
+}
+
+sub init { return } # no-op
+
+###########################################################################
+
+sub maketext {
+ # Remember, this can fail. Failure is controllable many ways.
+ Carp::croak 'maketext requires at least one parameter' unless @_ > 1;
+
+ my($handle, $phrase) = splice(@_,0,2);
+ Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase));
+
+
+ # Don't interefere with $@ in case that's being interpolated into the msg.
+ local $@;
+
+ # Look up the value:
+
+ my $value;
+ foreach my $h_r (
+ @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
+ ) {
+ DEBUG and warn "* Looking up \"$phrase\" in $h_r\n";
+ if(exists $h_r->{$phrase}) {
+ DEBUG and warn " Found \"$phrase\" in $h_r\n";
+ unless(ref($value = $h_r->{$phrase})) {
+ # Nonref means it's not yet compiled. Compile and replace.
+ $value = $h_r->{$phrase} = $handle->_compile($value);
+ }
+ last;
+ }
+ elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
+ # it's an auto lex, and this is an autoable key!
+ DEBUG and warn " Automaking \"$phrase\" into $h_r\n";
+
+ $value = $h_r->{$phrase} = $handle->_compile($phrase);
+ last;
+ }
+ DEBUG>1 and print " Not found in $h_r, nor automakable\n";
+ # else keep looking
+ }
+
+ unless(defined($value)) {
+ DEBUG and warn "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n";
+ if(ref($handle) and $handle->{'fail'}) {
+ DEBUG and warn "WARNING0: maketext fails looking for <$phrase>\n";
+ my $fail;
+ if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
+ return &{$fail}($handle, $phrase, @_);
+ # If it ever returns, it should return a good value.
+ }
+ else { # It's a method name
+ return $handle->$fail($phrase, @_);
+ # If it ever returns, it should return a good value.
+ }
+ }
+ else {
+ # All we know how to do is this;
+ Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
+ }
+ }
+
+ return $$value if ref($value) eq 'SCALAR';
+ return $value unless ref($value) eq 'CODE';
+
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if ($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ {\n in bracket code [compiled line $1],}s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ }
+ else {
+ return $value;
+ }
+}
+
+###########################################################################
+
+sub get_handle { # This is a constructor and, yes, it CAN FAIL.
+ # Its class argument has to be the base class for the current
+ # application's l10n files.
+
+ my($base_class, @languages) = @_;
+ $base_class = ref($base_class) || $base_class;
+ # Complain if they use __PACKAGE__ as a project base class?
+
+ if( @languages ) {
+ DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ if($USING_LANGUAGE_TAGS) { # An explicit language-list was given!
+ @languages =
+ map {; $_, I18N::LangTags::alternate_language_tags($_) }
+ # Catch alternation
+ map I18N::LangTags::locale2language_tag($_),
+ # If it's a lg tag, fine, pass thru (untainted)
+ # If it's a locale ID, try converting to a lg tag (untainted),
+ # otherwise nix it.
+ @languages;
+ DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+ }
+ else {
+ @languages = $base_class->_ambient_langprefs;
+ }
+
+ @languages = $base_class->_langtag_munging(@languages);
+
+ my %seen;
+ foreach my $module_name ( map { $base_class . '::' . $_ } @languages ) {
+ next unless length $module_name; # sanity
+ next if $seen{$module_name}++ # Already been here, and it was no-go
+ || !&_try_use($module_name); # Try to use() it, but can't it.
+ return($module_name->new); # Make it!
+ }
+
+ return undef; # Fail!
+}
+
+###########################################################################
+
+sub _langtag_munging {
+ my($base_class, @languages) = @_;
+
+ # We have all these DEBUG statements because otherwise it's hard as hell
+ # to diagnose ifwhen something goes wrong.
+
+ DEBUG and warn 'Lgs1: ', map("<$_>", @languages), "\n";
+
+ if($USING_LANGUAGE_TAGS) {
+ DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = $base_class->_add_supers( @languages );
+
+ push @languages, I18N::LangTags::panic_languages(@languages);
+ DEBUG and warn "After adding panic languages:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ push @languages, $base_class->fallback_languages;
+ # You are free to override fallback_languages to return empty-list!
+ DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ @languages = # final bit of processing to turn them into classname things
+ map {
+ my $it = $_; # copy
+ $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
+ $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
+ $it;
+ } @languages
+ ;
+ DEBUG and warn "Nearing end of munging:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+ else {
+ DEBUG and warn "Bypassing language-tags.\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+
+ DEBUG and warn "Before adding fallback classes:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ push @languages, $base_class->fallback_language_classes;
+ # You are free to override that to return whatever.
+
+ DEBUG and warn "Finally:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ return @languages;
+}
+
+###########################################################################
+
+sub _ambient_langprefs {
+ require I18N::LangTags::Detect;
+ return I18N::LangTags::Detect::detect();
+}
+
+###########################################################################
+
+sub _add_supers {
+ my($base_class, @languages) = @_;
+
+ if (!$MATCH_SUPERS) {
+ # Nothing
+ DEBUG and warn "Bypassing any super-matching.\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ }
+ elsif( $MATCH_SUPERS_TIGHTLY ) {
+ DEBUG and warn "Before adding new supers tightly:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = I18N::LangTags::implicate_supers( @languages );
+ DEBUG and warn "After adding new supers tightly:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ }
+ else {
+ DEBUG and warn "Before adding supers to end:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = I18N::LangTags::implicate_supers_strictly( @languages );
+ DEBUG and warn "After adding supers to end:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+
+ return @languages;
+}
+
+###########################################################################
+#
+# This is where most people should stop reading.
+#
+###########################################################################
+
+use Locale::Maketext::GutsLoader;
+
+###########################################################################
+
+my %tried = ();
+# memoization of whether we've used this module, or found it unusable.
+
+sub _try_use { # Basically a wrapper around "require Modulename"
+ # "Many men have tried..." "They tried and failed?" "They tried and died."
+ return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
+
+ my $module = $_[0]; # ASSUME sane module name!
+ { no strict 'refs';
+ return($tried{$module} = 1)
+ if %{$module . '::Lexicon'} or @{$module . '::ISA'};
+ # weird case: we never use'd it, but there it is!
+ }
+
+ DEBUG and warn " About to use $module ...\n";
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
+ if($@) {
+ DEBUG and warn "Error using $module \: $@\n";
+ return $tried{$module} = 0;
+ }
+ else {
+ DEBUG and warn " OK, $module is used\n";
+ return $tried{$module} = 1;
+ }
+}
+
+#--------------------------------------------------------------------------
+
+sub _lex_refs { # report the lexicon references for this handle's class
+ # returns an arrayREF!
+ no strict 'refs';
+ no warnings 'once';
+ my $class = ref($_[0]) || $_[0];
+ DEBUG and warn "Lex refs lookup on $class\n";
+ return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
+
+ my @lex_refs;
+ my $seen_r = ref($_[1]) ? $_[1] : {};
+
+ if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
+ push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
+ DEBUG and warn '%' . $class . '::Lexicon contains ',
+ scalar(keys %{$class . '::Lexicon'}), " entries\n";
+ }
+
+ # Implements depth(height?)-first recursive searching of superclasses.
+ # In hindsight, I suppose I could have just used Class::ISA!
+ foreach my $superclass (@{$class . '::ISA'}) {
+ DEBUG and warn " Super-class search into $superclass\n";
+ next if $seen_r->{$superclass}++;
+ push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
+ }
+
+ $isa_scan{$class} = \@lex_refs; # save for next time
+ return \@lex_refs;
+}
+
+sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext.pod b/Master/tlpkg/tlperl/lib/Locale/Maketext.pod
new file mode 100644
index 00000000000..15533e4e870
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext.pod
@@ -0,0 +1,1326 @@
+
+# Time-stamp: "2004-01-11 18:35:34 AST"
+
+=head1 NAME
+
+Locale::Maketext - framework for localization
+
+=head1 SYNOPSIS
+
+ package MyProgram;
+ use strict;
+ use MyProgram::L10N;
+ # ...which inherits from Locale::Maketext
+ my $lh = MyProgram::L10N->get_handle() || die "What language?";
+ ...
+ # And then any messages your program emits, like:
+ warn $lh->maketext( "Can't open file [_1]: [_2]\n", $f, $! );
+ ...
+
+=head1 DESCRIPTION
+
+It is a common feature of applications (whether run directly,
+or via the Web) for them to be "localized" -- i.e., for them
+to a present an English interface to an English-speaker, a German
+interface to a German-speaker, and so on for all languages it's
+programmed with. Locale::Maketext
+is a framework for software localization; it provides you with the
+tools for organizing and accessing the bits of text and text-processing
+code that you need for producing localized applications.
+
+In order to make sense of Maketext and how all its
+components fit together, you should probably
+go read L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13>, and
+I<then> read the following documentation.
+
+You may also want to read over the source for C<File::Findgrep>
+and its constituent modules -- they are a complete (if small)
+example application that uses Maketext.
+
+=head1 QUICK OVERVIEW
+
+The basic design of Locale::Maketext is object-oriented, and
+Locale::Maketext is an abstract base class, from which you
+derive a "project class".
+The project class (with a name like "TkBocciBall::Localize",
+which you then use in your module) is in turn the base class
+for all the "language classes" for your project
+(with names "TkBocciBall::Localize::it",
+"TkBocciBall::Localize::en",
+"TkBocciBall::Localize::fr", etc.).
+
+A language class is
+a class containing a lexicon of phrases as class data,
+and possibly also some methods that are of use in interpreting
+phrases in the lexicon, or otherwise dealing with text in that
+language.
+
+An object belonging to a language class is called a "language
+handle"; it's typically a flyweight object.
+
+The normal course of action is to call:
+
+ use TkBocciBall::Localize; # the localization project class
+ $lh = TkBocciBall::Localize->get_handle();
+ # Depending on the user's locale, etc., this will
+ # make a language handle from among the classes available,
+ # and any defaults that you declare.
+ die "Couldn't make a language handle??" unless $lh;
+
+From then on, you use the C<maketext> function to access
+entries in whatever lexicon(s) belong to the language handle
+you got. So, this:
+
+ print $lh->maketext("You won!"), "\n";
+
+...emits the right text for this language. If the object
+in C<$lh> belongs to class "TkBocciBall::Localize::fr" and
+%TkBocciBall::Localize::fr::Lexicon contains C<("You won!"
+=E<gt> "Tu as gagnE<eacute>!")>, then the above
+code happily tells the user "Tu as gagnE<eacute>!".
+
+=head1 METHODS
+
+Locale::Maketext offers a variety of methods, which fall
+into three categories:
+
+=over
+
+=item *
+
+Methods to do with constructing language handles.
+
+=item *
+
+C<maketext> and other methods to do with accessing %Lexicon data
+for a given language handle.
+
+=item *
+
+Methods that you may find it handy to use, from routines of
+yours that you put in %Lexicon entries.
+
+=back
+
+These are covered in the following section.
+
+=head2 Construction Methods
+
+These are to do with constructing a language handle:
+
+=over
+
+=item *
+
+$lh = YourProjClass->get_handle( ...langtags... ) || die "lg-handle?";
+
+This tries loading classes based on the language-tags you give (like
+C<("en-US", "sk", "kon", "es-MX", "ja", "i-klingon")>, and for the first class
+that succeeds, returns YourProjClass::I<language>->new().
+
+If it runs thru the entire given list of language-tags, and finds no classes
+for those exact terms, it then tries "superordinate" language classes.
+So if no "en-US" class (i.e., YourProjClass::en_us)
+was found, nor classes for anything else in that list, we then try
+its superordinate, "en" (i.e., YourProjClass::en), and so on thru
+the other language-tags in the given list: "es".
+(The other language-tags in our example list:
+happen to have no superordinates.)
+
+If none of those language-tags leads to loadable classes, we then
+try classes derived from YourProjClass->fallback_languages() and
+then if nothing comes of that, we use classes named by
+YourProjClass->fallback_language_classes(). Then in the (probably
+quite unlikely) event that that fails, we just return undef.
+
+=item *
+
+$lh = YourProjClass->get_handleB<()> || die "lg-handle?";
+
+When C<get_handle> is called with an empty parameter list, magic happens:
+
+If C<get_handle> senses that it's running in program that was
+invoked as a CGI, then it tries to get language-tags out of the
+environment variable "HTTP_ACCEPT_LANGUAGE", and it pretends that
+those were the languages passed as parameters to C<get_handle>.
+
+Otherwise (i.e., if not a CGI), this tries various OS-specific ways
+to get the language-tags for the current locale/language, and then
+pretends that those were the value(s) passed to C<get_handle>.
+
+Currently this OS-specific stuff consists of looking in the environment
+variables "LANG" and "LANGUAGE"; and on MSWin machines (where those
+variables are typically unused), this also tries using
+the module Win32::Locale to get a language-tag for whatever language/locale
+is currently selected in the "Regional Settings" (or "International"?)
+Control Panel. I welcome further
+suggestions for making this do the Right Thing under other operating
+systems that support localization.
+
+If you're using localization in an application that keeps a configuration
+file, you might consider something like this in your project class:
+
+ sub get_handle_via_config {
+ my $class = $_[0];
+ my $chosen_language = $Config_settings{'language'};
+ my $lh;
+ if($chosen_language) {
+ $lh = $class->get_handle($chosen_language)
+ || die "No language handle for \"$chosen_language\" or the like";
+ } else {
+ # Config file missing, maybe?
+ $lh = $class->get_handle()
+ || die "Can't get a language handle";
+ }
+ return $lh;
+ }
+
+=item *
+
+$lh = YourProjClass::langname->new();
+
+This constructs a language handle. You usually B<don't> call this
+directly, but instead let C<get_handle> find a language class to C<use>
+and to then call ->new on.
+
+=item *
+
+$lh->init();
+
+This is called by ->new to initialize newly-constructed language handles.
+If you define an init method in your class, remember that it's usually
+considered a good idea to call $lh->SUPER::init in it (presumably at the
+beginning), so that all classes get a chance to initialize a new object
+however they see fit.
+
+=item *
+
+YourProjClass->fallback_languages()
+
+C<get_handle> appends the return value of this to the end of
+whatever list of languages you pass C<get_handle>. Unless
+you override this method, your project class
+will inherit Locale::Maketext's C<fallback_languages>, which
+currently returns C<('i-default', 'en', 'en-US')>.
+("i-default" is defined in RFC 2277).
+
+This method (by having it return the name
+of a language-tag that has an existing language class)
+can be used for making sure that
+C<get_handle> will always manage to construct a language
+handle (assuming your language classes are in an appropriate
+@INC directory). Or you can use the next method:
+
+=item *
+
+YourProjClass->fallback_language_classes()
+
+C<get_handle> appends the return value of this to the end
+of the list of classes it will try using. Unless
+you override this method, your project class
+will inherit Locale::Maketext's C<fallback_language_classes>,
+which currently returns an empty list, C<()>.
+By setting this to some value (namely, the name of a loadable
+language class), you can be sure that
+C<get_handle> will always manage to construct a language
+handle.
+
+=back
+
+=head2 The "maketext" Method
+
+This is the most important method in Locale::Maketext:
+
+ $text = $lh->maketext(I<key>, ...parameters for this phrase...);
+
+This looks in the %Lexicon of the language handle
+$lh and all its superclasses, looking
+for an entry whose key is the string I<key>. Assuming such
+an entry is found, various things then happen, depending on the
+value found:
+
+If the value is a scalarref, the scalar is dereferenced and returned
+(and any parameters are ignored).
+
+If the value is a coderef, we return &$value($lh, ...parameters...).
+
+If the value is a string that I<doesn't> look like it's in Bracket Notation,
+we return it (after replacing it with a scalarref, in its %Lexicon).
+
+If the value I<does> look like it's in Bracket Notation, then we compile
+it into a sub, replace the string in the %Lexicon with the new coderef,
+and then we return &$new_sub($lh, ...parameters...).
+
+Bracket Notation is discussed in a later section. Note
+that trying to compile a string into Bracket Notation can throw
+an exception if the string is not syntactically valid (say, by not
+balancing brackets right.)
+
+Also, calling &$coderef($lh, ...parameters...) can throw any sort of
+exception (if, say, code in that sub tries to divide by zero). But
+a very common exception occurs when you have Bracket
+Notation text that says to call a method "foo", but there is no such
+method. (E.g., "You have [quaB<tn>,_1,ball]." will throw an exception
+on trying to call $lh->quaB<tn>($_[1],'ball') -- you presumably meant
+"quant".) C<maketext> catches these exceptions, but only to make the
+error message more readable, at which point it rethrows the exception.
+
+An exception I<may> be thrown if I<key> is not found in any
+of $lh's %Lexicon hashes. What happens if a key is not found,
+is discussed in a later section, "Controlling Lookup Failure".
+
+Note that you might find it useful in some cases to override
+the C<maketext> method with an "after method", if you want to
+translate encodings, or even scripts:
+
+ package YrProj::zh_cn; # Chinese with PRC-style glyphs
+ use base ('YrProj::zh_tw'); # Taiwan-style
+ sub maketext {
+ my $self = shift(@_);
+ my $value = $self->maketext(@_);
+ return Chineeze::taiwan2mainland($value);
+ }
+
+Or you may want to override it with something that traps
+any exceptions, if that's critical to your program:
+
+ sub maketext {
+ my($lh, @stuff) = @_;
+ my $out;
+ eval { $out = $lh->SUPER::maketext(@stuff) };
+ return $out unless $@;
+ ...otherwise deal with the exception...
+ }
+
+Other than those two situations, I don't imagine that
+it's useful to override the C<maketext> method. (If
+you run into a situation where it is useful, I'd be
+interested in hearing about it.)
+
+=over
+
+=item $lh->fail_with I<or> $lh->fail_with(I<PARAM>)
+
+=item $lh->failure_handler_auto
+
+These two methods are discussed in the section "Controlling
+Lookup Failure".
+
+=back
+
+=head2 Utility Methods
+
+These are methods that you may find it handy to use, generally
+from %Lexicon routines of yours (whether expressed as
+Bracket Notation or not).
+
+=over
+
+=item $language->quant($number, $singular)
+
+=item $language->quant($number, $singular, $plural)
+
+=item $language->quant($number, $singular, $plural, $negative)
+
+This is generally meant to be called from inside Bracket Notation
+(which is discussed later), as in
+
+ "Your search matched [quant,_1,document]!"
+
+It's for I<quantifying> a noun (i.e., saying how much of it there is,
+while giving the correct form of it). The behavior of this method is
+handy for English and a few other Western European languages, and you
+should override it for languages where it's not suitable. You can feel
+free to read the source, but the current implementation is basically
+as this pseudocode describes:
+
+ if $number is 0 and there's a $negative,
+ return $negative;
+ elsif $number is 1,
+ return "1 $singular";
+ elsif there's a $plural,
+ return "$number $plural";
+ else
+ return "$number " . $singular . "s";
+ #
+ # ...except that we actually call numf to
+ # stringify $number before returning it.
+
+So for English (with Bracket Notation)
+C<"...[quant,_1,file]..."> is fine (for 0 it returns "0 files",
+for 1 it returns "1 file", and for more it returns "2 files", etc.)
+
+But for "directory", you'd want C<"[quant,_1,directory,directories]">
+so that our elementary C<quant> method doesn't think that the
+plural of "directory" is "directorys". And you might find that the
+output may sound better if you specify a negative form, as in:
+
+ "[quant,_1,file,files,No files] matched your query.\n"
+
+Remember to keep in mind verb agreement (or adjectives too, in
+other languages), as in:
+
+ "[quant,_1,document] were matched.\n"
+
+Because if _1 is one, you get "1 document B<were> matched".
+An acceptable hack here is to do something like this:
+
+ "[quant,_1,document was, documents were] matched.\n"
+
+=item $language->numf($number)
+
+This returns the given number formatted nicely according to
+this language's conventions. Maketext's default method is
+mostly to just take the normal string form of the number
+(applying sprintf "%G" for only very large numbers), and then
+to add commas as necessary. (Except that
+we apply C<tr/,./.,/> if $language->{'numf_comma'} is true;
+that's a bit of a hack that's useful for languages that express
+two million as "2.000.000" and not as "2,000,000").
+
+If you want anything fancier, consider overriding this with something
+that uses L<Number::Format|Number::Format>, or does something else
+entirely.
+
+Note that numf is called by quant for stringifying all quantifying
+numbers.
+
+=item $language->sprintf($format, @items)
+
+This is just a wrapper around Perl's normal C<sprintf> function.
+It's provided so that you can use "sprintf" in Bracket Notation:
+
+ "Couldn't access datanode [sprintf,%10x=~[%s~],_1,_2]!\n"
+
+returning...
+
+ Couldn't access datanode Stuff=[thangamabob]!
+
+=item $language->language_tag()
+
+Currently this just takes the last bit of C<ref($language)>, turns
+underscores to dashes, and returns it. So if $language is
+an object of class Hee::HOO::Haw::en_us, $language->language_tag()
+returns "en-us". (Yes, the usual representation for that language
+tag is "en-US", but case is I<never> considered meaningful in
+language-tag comparison.)
+
+You may override this as you like; Maketext doesn't use it for
+anything.
+
+=item $language->encoding()
+
+Currently this isn't used for anything, but it's provided
+(with default value of
+C<(ref($language) && $language-E<gt>{'encoding'})) or "iso-8859-1">
+) as a sort of suggestion that it may be useful/necessary to
+associate encodings with your language handles (whether on a
+per-class or even per-handle basis.)
+
+=back
+
+=head2 Language Handle Attributes and Internals
+
+A language handle is a flyweight object -- i.e., it doesn't (necessarily)
+carry any data of interest, other than just being a member of
+whatever class it belongs to.
+
+A language handle is implemented as a blessed hash. Subclasses of yours
+can store whatever data you want in the hash. Currently the only hash
+entry used by any crucial Maketext method is "fail", so feel free to
+use anything else as you like.
+
+B<Remember: Don't be afraid to read the Maketext source if there's
+any point on which this documentation is unclear.> This documentation
+is vastly longer than the module source itself.
+
+=over
+
+=back
+
+=head1 LANGUAGE CLASS HIERARCHIES
+
+These are Locale::Maketext's assumptions about the class
+hierarchy formed by all your language classes:
+
+=over
+
+=item *
+
+You must have a project base class, which you load, and
+which you then use as the first argument in
+the call to YourProjClass->get_handle(...). It should derive
+(whether directly or indirectly) from Locale::Maketext.
+It B<doesn't matter> how you name this class, although assuming this
+is the localization component of your Super Mega Program,
+good names for your project class might be
+SuperMegaProgram::Localization, SuperMegaProgram::L10N,
+SuperMegaProgram::I18N, SuperMegaProgram::International,
+or even SuperMegaProgram::Languages or SuperMegaProgram::Messages.
+
+=item *
+
+Language classes are what YourProjClass->get_handle will try to load.
+It will look for them by taking each language-tag (B<skipping> it
+if it doesn't look like a language-tag or locale-tag!), turning it to
+all lowercase, turning dashes to underscores, and appending it
+to YourProjClass . "::". So this:
+
+ $lh = YourProjClass->get_handle(
+ 'en-US', 'fr', 'kon', 'i-klingon', 'i-klingon-romanized'
+ );
+
+will try loading the classes
+YourProjClass::en_us (note lowercase!), YourProjClass::fr,
+YourProjClass::kon,
+YourProjClass::i_klingon
+and YourProjClass::i_klingon_romanized. (And it'll stop at the
+first one that actually loads.)
+
+=item *
+
+I assume that each language class derives (directly or indirectly)
+from your project class, and also defines its @ISA, its %Lexicon,
+or both. But I anticipate no dire consequences if these assumptions
+do not hold.
+
+=item *
+
+Language classes may derive from other language classes (although they
+should have "use I<Thatclassname>" or "use base qw(I<...classes...>)").
+They may derive from the project
+class. They may derive from some other class altogether. Or via
+multiple inheritance, it may derive from any mixture of these.
+
+=item *
+
+I foresee no problems with having multiple inheritance in
+your hierarchy of language classes. (As usual, however, Perl will
+complain bitterly if you have a cycle in the hierarchy: i.e., if
+any class is its own ancestor.)
+
+=back
+
+=head1 ENTRIES IN EACH LEXICON
+
+A typical %Lexicon entry is meant to signify a phrase,
+taking some number (0 or more) of parameters. An entry
+is meant to be accessed by via
+a string I<key> in $lh->maketext(I<key>, ...parameters...),
+which should return a string that is generally meant for
+be used for "output" to the user -- regardless of whether
+this actually means printing to STDOUT, writing to a file,
+or putting into a GUI widget.
+
+While the key must be a string value (since that's a basic
+restriction that Perl places on hash keys), the value in
+the lexicon can currently be of several types:
+a defined scalar, scalarref, or coderef. The use of these is
+explained above, in the section 'The "maketext" Method', and
+Bracket Notation for strings is discussed in the next section.
+
+While you can use arbitrary unique IDs for lexicon keys
+(like "_min_larger_max_error"), it is often
+useful for if an entry's key is itself a valid value, like
+this example error message:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+
+Compare this code that uses an arbitrary ID...
+
+ die $lh->maketext( "_min_larger_max_error", $min, $max )
+ if $min > $max;
+
+...to this code that uses a key-as-value:
+
+ die $lh->maketext(
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ $min, $max
+ ) if $min > $max;
+
+The second is, in short, more readable. In particular, it's obvious
+that the number of parameters you're feeding to that phrase (two) is
+the number of parameters that it I<wants> to be fed. (Since you see
+_1 and a _2 being used in the key there.)
+
+Also, once a project is otherwise
+complete and you start to localize it, you can scrape together
+all the various keys you use, and pass it to a translator; and then
+the translator's work will go faster if what he's presented is this:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ => "", # fill in something here, Jacques!
+
+rather than this more cryptic mess:
+
+ "_min_larger_max_error"
+ => "", # fill in something here, Jacques
+
+I think that keys as lexicon values makes the completed lexicon
+entries more readable:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ => "Le minimum ([_1]) est plus grand que le maximum ([_2])!\n",
+
+Also, having valid values as keys becomes very useful if you set
+up an _AUTO lexicon. _AUTO lexicons are discussed in a later
+section.
+
+I almost always use keys that are themselves
+valid lexicon values. One notable exception is when the value is
+quite long. For example, to get the screenful of data that
+a command-line program might return when given an unknown switch,
+I often just use a brief, self-explanatory key such as "_USAGE_MESSAGE". At that point I then go
+and immediately to define that lexicon entry in the
+ProjectClass::L10N::en lexicon (since English is always my "project
+language"):
+
+ '_USAGE_MESSAGE' => <<'EOSTUFF',
+ ...long long message...
+ EOSTUFF
+
+and then I can use it as:
+
+ getopt('oDI', \%opts) or die $lh->maketext('_USAGE_MESSAGE');
+
+Incidentally,
+note that each class's C<%Lexicon> inherits-and-extends
+the lexicons in its superclasses. This is not because these are
+special hashes I<per se>, but because you access them via the
+C<maketext> method, which looks for entries across all the
+C<%Lexicon> hashes in a language class I<and> all its ancestor classes.
+(This is because the idea of "class data" isn't directly implemented
+in Perl, but is instead left to individual class-systems to implement
+as they see fit..)
+
+Note that you may have things stored in a lexicon
+besides just phrases for output: for example, if your program
+takes input from the keyboard, asking a "(Y/N)" question,
+you probably need to know what the equivalent of "Y[es]/N[o]" is
+in whatever language. You probably also need to know what
+the equivalents of the answers "y" and "n" are. You can
+store that information in the lexicon (say, under the keys
+"~answer_y" and "~answer_n", and the long forms as
+"~answer_yes" and "~answer_no", where "~" is just an ad-hoc
+character meant to indicate to programmers/translators that
+these are not phrases for output).
+
+Or instead of storing this in the language class's lexicon,
+you can (and, in some cases, really should) represent the same bit
+of knowledge as code in a method in the language class. (That
+leaves a tidy distinction between the lexicon as the things we
+know how to I<say>, and the rest of the things in the lexicon class
+as things that we know how to I<do>.) Consider
+this example of a processor for responses to French "oui/non"
+questions:
+
+ sub y_or_n {
+ return undef unless defined $_[1] and length $_[1];
+ my $answer = lc $_[1]; # smash case
+ return 1 if $answer eq 'o' or $answer eq 'oui';
+ return 0 if $answer eq 'n' or $answer eq 'non';
+ return undef;
+ }
+
+...which you'd then call in a construct like this:
+
+ my $response;
+ until(defined $response) {
+ print $lh->maketext("Open the pod bay door (y/n)? ");
+ $response = $lh->y_or_n( get_input_from_keyboard_somehow() );
+ }
+ if($response) { $pod_bay_door->open() }
+ else { $pod_bay_door->leave_closed() }
+
+Other data worth storing in a lexicon might be things like
+filenames for language-targetted resources:
+
+ ...
+ "_main_splash_png"
+ => "/styles/en_us/main_splash.png",
+ "_main_splash_imagemap"
+ => "/styles/en_us/main_splash.incl",
+ "_general_graphics_path"
+ => "/styles/en_us/",
+ "_alert_sound"
+ => "/styles/en_us/hey_there.wav",
+ "_forward_icon"
+ => "left_arrow.png",
+ "_backward_icon"
+ => "right_arrow.png",
+ # In some other languages, left equals
+ # BACKwards, and right is FOREwards.
+ ...
+
+You might want to do the same thing for expressing key bindings
+or the like (since hardwiring "q" as the binding for the function
+that quits a screen/menu/program is useful only if your language
+happens to associate "q" with "quit"!)
+
+=head1 BRACKET NOTATION
+
+Bracket Notation is a crucial feature of Locale::Maketext. I mean
+Bracket Notation to provide a replacement for the use of sprintf formatting.
+Everything you do with Bracket Notation could be done with a sub block,
+but bracket notation is meant to be much more concise.
+
+Bracket Notation is a like a miniature "template" system (in the sense
+of L<Text::Template|Text::Template>, not in the sense of C++ templates),
+where normal text is passed thru basically as is, but text in special
+regions is specially interpreted. In Bracket Notation, you use square brackets ("[...]"),
+not curly braces ("{...}") to note sections that are specially interpreted.
+
+For example, here all the areas that are taken literally are underlined with
+a "^", and all the in-bracket special regions are underlined with an X:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ ^^^^^^^^^ XX ^^^^^^^^^^^^^^^^^^^^^^^^^^ XX ^^^^
+
+When that string is compiled from bracket notation into a real Perl sub,
+it's basically turned into:
+
+ sub {
+ my $lh = $_[0];
+ my @params = @_;
+ return join '',
+ "Minimum (",
+ ...some code here...
+ ") is larger than maximum (",
+ ...some code here...
+ ")!\n",
+ }
+ # to be called by $lh->maketext(KEY, params...)
+
+In other words, text outside bracket groups is turned into string
+literals. Text in brackets is rather more complex, and currently follows
+these rules:
+
+=over
+
+=item *
+
+Bracket groups that are empty, or which consist only of whitespace,
+are ignored. (Examples: "[]", "[ ]", or a [ and a ] with returns
+and/or tabs and/or spaces between them.
+
+Otherwise, each group is taken to be a comma-separated group of items,
+and each item is interpreted as follows:
+
+=item *
+
+An item that is "_I<digits>" or "_-I<digits>" is interpreted as
+$_[I<value>]. I.e., "_1" becomes with $_[1], and "_-3" is interpreted
+as $_[-3] (in which case @_ should have at least three elements in it).
+Note that $_[0] is the language handle, and is typically not named
+directly.
+
+=item *
+
+An item "_*" is interpreted to mean "all of @_ except $_[0]".
+I.e., C<@_[1..$#_]>. Note that this is an empty list in the case
+of calls like $lh->maketext(I<key>) where there are no
+parameters (except $_[0], the language handle).
+
+=item *
+
+Otherwise, each item is interpreted as a string literal.
+
+=back
+
+The group as a whole is interpreted as follows:
+
+=over
+
+=item *
+
+If the first item in a bracket group looks like a method name,
+then that group is interpreted like this:
+
+ $lh->that_method_name(
+ ...rest of items in this group...
+ ),
+
+=item *
+
+If the first item in a bracket group is "*", it's taken as shorthand
+for the so commonly called "quant" method. Similarly, if the first
+item in a bracket group is "#", it's taken to be shorthand for
+"numf".
+
+=item *
+
+If the first item in a bracket group is the empty-string, or "_*"
+or "_I<digits>" or "_-I<digits>", then that group is interpreted
+as just the interpolation of all its items:
+
+ join('',
+ ...rest of items in this group...
+ ),
+
+Examples: "[_1]" and "[,_1]", which are synonymous; and
+"C<[,ID-(,_4,-,_2,)]>", which compiles as
+C<join "", "ID-(", $_[4], "-", $_[2], ")">.
+
+=item *
+
+Otherwise this bracket group is invalid. For example, in the group
+"[!@#,whatever]", the first item C<"!@#"> is neither the empty-string,
+"_I<number>", "_-I<number>", "_*", nor a valid method name; and so
+Locale::Maketext will throw an exception of you try compiling an
+expression containing this bracket group.
+
+=back
+
+Note, incidentally, that items in each group are comma-separated,
+not C</\s*,\s*/>-separated. That is, you might expect that this
+bracket group:
+
+ "Hoohah [foo, _1 , bar ,baz]!"
+
+would compile to this:
+
+ sub {
+ my $lh = $_[0];
+ return join '',
+ "Hoohah ",
+ $lh->foo( $_[1], "bar", "baz"),
+ "!",
+ }
+
+But it actually compiles as this:
+
+ sub {
+ my $lh = $_[0];
+ return join '',
+ "Hoohah ",
+ $lh->foo(" _1 ", " bar ", "baz"), # note the <space> in " bar "
+ "!",
+ }
+
+In the notation discussed so far, the characters "[" and "]" are given
+special meaning, for opening and closing bracket groups, and "," has
+a special meaning inside bracket groups, where it separates items in the
+group. This begs the question of how you'd express a literal "[" or
+"]" in a Bracket Notation string, and how you'd express a literal
+comma inside a bracket group. For this purpose I've adopted "~" (tilde)
+as an escape character: "~[" means a literal '[' character anywhere
+in Bracket Notation (i.e., regardless of whether you're in a bracket
+group or not), and ditto for "~]" meaning a literal ']', and "~," meaning
+a literal comma. (Altho "," means a literal comma outside of
+bracket groups -- it's only inside bracket groups that commas are special.)
+
+And on the off chance you need a literal tilde in a bracket expression,
+you get it with "~~".
+
+Currently, an unescaped "~" before a character
+other than a bracket or a comma is taken to mean just a "~" and that
+character. I.e., "~X" means the same as "~~X" -- i.e., one literal tilde,
+and then one literal "X". However, by using "~X", you are assuming that
+no future version of Maketext will use "~X" as a magic escape sequence.
+In practice this is not a great problem, since first off you can just
+write "~~X" and not worry about it; second off, I doubt I'll add lots
+of new magic characters to bracket notation; and third off, you
+aren't likely to want literal "~" characters in your messages anyway,
+since it's not a character with wide use in natural language text.
+
+Brackets must be balanced -- every openbracket must have
+one matching closebracket, and vice versa. So these are all B<invalid>:
+
+ "I ate [quant,_1,rhubarb pie."
+ "I ate [quant,_1,rhubarb pie[."
+ "I ate quant,_1,rhubarb pie]."
+ "I ate quant,_1,rhubarb pie[."
+
+Currently, bracket groups do not nest. That is, you B<cannot> say:
+
+ "Foo [bar,baz,[quux,quuux]]\n";
+
+If you need a notation that's that powerful, use normal Perl:
+
+ %Lexicon = (
+ ...
+ "some_key" => sub {
+ my $lh = $_[0];
+ join '',
+ "Foo ",
+ $lh->bar('baz', $lh->quux('quuux')),
+ "\n",
+ },
+ ...
+ );
+
+Or write the "bar" method so you don't need to pass it the
+output from calling quux.
+
+I do not anticipate that you will need (or particularly want)
+to nest bracket groups, but you are welcome to email me with
+convincing (real-life) arguments to the contrary.
+
+=head1 AUTO LEXICONS
+
+If maketext goes to look in an individual %Lexicon for an entry
+for I<key> (where I<key> does not start with an underscore), and
+sees none, B<but does see> an entry of "_AUTO" => I<some_true_value>,
+then we actually define $Lexicon{I<key>} = I<key> right then and there,
+and then use that value as if it had been there all
+along. This happens before we even look in any superclass %Lexicons!
+
+(This is meant to be somewhat like the AUTOLOAD mechanism in
+Perl's function call system -- or, looked at another way,
+like the L<AutoLoader|AutoLoader> module.)
+
+I can picture all sorts of circumstances where you just
+do not want lookup to be able to fail (since failing
+normally means that maketext throws a C<die>, although
+see the next section for greater control over that). But
+here's one circumstance where _AUTO lexicons are meant to
+be I<especially> useful:
+
+As you're writing an application, you decide as you go what messages
+you need to emit. Normally you'd go to write this:
+
+ if(-e $filename) {
+ go_process_file($filename)
+ } else {
+ print qq{Couldn't find file "$filename"!\n};
+ }
+
+but since you anticipate localizing this, you write:
+
+ use ThisProject::I18N;
+ my $lh = ThisProject::I18N->get_handle();
+ # For the moment, assume that things are set up so
+ # that we load class ThisProject::I18N::en
+ # and that that's the class that $lh belongs to.
+ ...
+ if(-e $filename) {
+ go_process_file($filename)
+ } else {
+ print $lh->maketext(
+ qq{Couldn't find file "[_1]"!\n}, $filename
+ );
+ }
+
+Now, right after you've just written the above lines, you'd
+normally have to go open the file
+ThisProject/I18N/en.pm, and immediately add an entry:
+
+ "Couldn't find file \"[_1]\"!\n"
+ => "Couldn't find file \"[_1]\"!\n",
+
+But I consider that somewhat of a distraction from the work
+of getting the main code working -- to say nothing of the fact
+that I often have to play with the program a few times before
+I can decide exactly what wording I want in the messages (which
+in this case would require me to go changing three lines of code:
+the call to maketext with that key, and then the two lines in
+ThisProject/I18N/en.pm).
+
+However, if you set "_AUTO => 1" in the %Lexicon in,
+ThisProject/I18N/en.pm (assuming that English (en) is
+the language that all your programmers will be using for this
+project's internal message keys), then you don't ever have to
+go adding lines like this
+
+ "Couldn't find file \"[_1]\"!\n"
+ => "Couldn't find file \"[_1]\"!\n",
+
+to ThisProject/I18N/en.pm, because if _AUTO is true there,
+then just looking for an entry with the key "Couldn't find
+file \"[_1]\"!\n" in that lexicon will cause it to be added,
+with that value!
+
+Note that the reason that keys that start with "_"
+are immune to _AUTO isn't anything generally magical about
+the underscore character -- I just wanted a way to have most
+lexicon keys be autoable, except for possibly a few, and I
+arbitrarily decided to use a leading underscore as a signal
+to distinguish those few.
+
+=head1 CONTROLLING LOOKUP FAILURE
+
+If you call $lh->maketext(I<key>, ...parameters...),
+and there's no entry I<key> in $lh's class's %Lexicon, nor
+in the superclass %Lexicon hash, I<and> if we can't auto-make
+I<key> (because either it starts with a "_", or because none
+of its lexicons have C<_AUTO =E<gt> 1,>), then we have
+failed to find a normal way to maketext I<key>. What then
+happens in these failure conditions, depends on the $lh object's
+"fail" attribute.
+
+If the language handle has no "fail" attribute, maketext
+will simply throw an exception (i.e., it calls C<die>, mentioning
+the I<key> whose lookup failed, and naming the line number where
+the calling $lh->maketext(I<key>,...) was.
+
+If the language handle has a "fail" attribute whose value is a
+coderef, then $lh->maketext(I<key>,...params...) gives up and calls:
+
+ return $that_subref->($lh, $key, @params);
+
+Otherwise, the "fail" attribute's value should be a string denoting
+a method name, so that $lh->maketext(I<key>,...params...) can
+give up with:
+
+ return $lh->$that_method_name($phrase, @params);
+
+The "fail" attribute can be accessed with the C<fail_with> method:
+
+ # Set to a coderef:
+ $lh->fail_with( \&failure_handler );
+
+ # Set to a method name:
+ $lh->fail_with( 'failure_method' );
+
+ # Set to nothing (i.e., so failure throws a plain exception)
+ $lh->fail_with( undef );
+
+ # Get the current value
+ $handler = $lh->fail_with();
+
+Now, as to what you may want to do with these handlers: Maybe you'd
+want to log what key failed for what class, and then die. Maybe
+you don't like C<die> and instead you want to send the error message
+to STDOUT (or wherever) and then merely C<exit()>.
+
+Or maybe you don't want to C<die> at all! Maybe you could use a
+handler like this:
+
+ # Make all lookups fall back onto an English value,
+ # but only after we log it for later fingerpointing.
+ my $lh_backup = ThisProject->get_handle('en');
+ open(LEX_FAIL_LOG, ">>wherever/lex.log") || die "GNAARGH $!";
+ sub lex_fail {
+ my($failing_lh, $key, $params) = @_;
+ print LEX_FAIL_LOG scalar(localtime), "\t",
+ ref($failing_lh), "\t", $key, "\n";
+ return $lh_backup->maketext($key,@params);
+ }
+
+Some users have expressed that they think this whole mechanism of
+having a "fail" attribute at all, seems a rather pointless complication.
+But I want Locale::Maketext to be usable for software projects of I<any>
+scale and type; and different software projects have different ideas
+of what the right thing is to do in failure conditions. I could simply
+say that failure always throws an exception, and that if you want to be
+careful, you'll just have to wrap every call to $lh->maketext in an
+S<eval { }>. However, I want programmers to reserve the right (via
+the "fail" attribute) to treat lookup failure as something other than
+an exception of the same level of severity as a config file being
+unreadable, or some essential resource being inaccessible.
+
+One possibly useful value for the "fail" attribute is the method name
+"failure_handler_auto". This is a method defined in the class
+Locale::Maketext itself. You set it with:
+
+ $lh->fail_with('failure_handler_auto');
+
+Then when you call $lh->maketext(I<key>, ...parameters...) and
+there's no I<key> in any of those lexicons, maketext gives up with
+
+ return $lh->failure_handler_auto($key, @params);
+
+But failure_handler_auto, instead of dying or anything, compiles
+$key, caching it in
+
+ $lh->{'failure_lex'}{$key} = $complied
+
+and then calls the compiled value, and returns that. (I.e., if
+$key looks like bracket notation, $compiled is a sub, and we return
+&{$compiled}(@params); but if $key is just a plain string, we just
+return that.)
+
+The effect of using "failure_auto_handler"
+is like an AUTO lexicon, except that it 1) compiles $key even if
+it starts with "_", and 2) you have a record in the new hashref
+$lh->{'failure_lex'} of all the keys that have failed for
+this object. This should avoid your program dying -- as long
+as your keys aren't actually invalid as bracket code, and as
+long as they don't try calling methods that don't exist.
+
+"failure_auto_handler" may not be exactly what you want, but I
+hope it at least shows you that maketext failure can be mitigated
+in any number of very flexible ways. If you can formalize exactly
+what you want, you should be able to express that as a failure
+handler. You can even make it default for every object of a given
+class, by setting it in that class's init:
+
+ sub init {
+ my $lh = $_[0]; # a newborn handle
+ $lh->SUPER::init();
+ $lh->fail_with('my_clever_failure_handler');
+ return;
+ }
+ sub my_clever_failure_handler {
+ ...you clever things here...
+ }
+
+=head1 HOW TO USE MAKETEXT
+
+Here is a brief checklist on how to use Maketext to localize
+applications:
+
+=over
+
+=item *
+
+Decide what system you'll use for lexicon keys. If you insist,
+you can use opaque IDs (if you're nostalgic for C<catgets>),
+but I have better suggestions in the
+section "Entries in Each Lexicon", above. Assuming you opt for
+meaningful keys that double as values (like "Minimum ([_1]) is
+larger than maximum ([_2])!\n"), you'll have to settle on what
+language those should be in. For the sake of argument, I'll
+call this English, specifically American English, "en-US".
+
+=item *
+
+Create a class for your localization project. This is
+the name of the class that you'll use in the idiom:
+
+ use Projname::L10N;
+ my $lh = Projname::L10N->get_handle(...) || die "Language?";
+
+Assuming you call your class Projname::L10N, create a class
+consisting minimally of:
+
+ package Projname::L10N;
+ use base qw(Locale::Maketext);
+ ...any methods you might want all your languages to share...
+
+ # And, assuming you want the base class to be an _AUTO lexicon,
+ # as is discussed a few sections up:
+
+ 1;
+
+=item *
+
+Create a class for the language your internal keys are in. Name
+the class after the language-tag for that language, in lowercase,
+with dashes changed to underscores. Assuming your project's first
+language is US English, you should call this Projname::L10N::en_us.
+It should consist minimally of:
+
+ package Projname::L10N::en_us;
+ use base qw(Projname::L10N);
+ %Lexicon = (
+ '_AUTO' => 1,
+ );
+ 1;
+
+(For the rest of this section, I'll assume that this "first
+language class" of Projname::L10N::en_us has
+_AUTO lexicon.)
+
+=item *
+
+Go and write your program. Everywhere in your program where
+you would say:
+
+ print "Foobar $thing stuff\n";
+
+instead do it thru maketext, using no variable interpolation in
+the key:
+
+ print $lh->maketext("Foobar [_1] stuff\n", $thing);
+
+If you get tired of constantly saying C<print $lh-E<gt>maketext>,
+consider making a functional wrapper for it, like so:
+
+ use Projname::L10N;
+ use vars qw($lh);
+ $lh = Projname::L10N->get_handle(...) || die "Language?";
+ sub pmt (@) { print( $lh->maketext(@_)) }
+ # "pmt" is short for "Print MakeText"
+ $Carp::Verbose = 1;
+ # so if maketext fails, we see made the call to pmt
+
+Besides whole phrases meant for output, anything language-dependent
+should be put into the class Projname::L10N::en_us,
+whether as methods, or as lexicon entries -- this is discussed
+in the section "Entries in Each Lexicon", above.
+
+=item *
+
+Once the program is otherwise done, and once its localization for
+the first language works right (via the data and methods in
+Projname::L10N::en_us), you can get together the data for translation.
+If your first language lexicon isn't an _AUTO lexicon, then you already
+have all the messages explicitly in the lexicon (or else you'd be
+getting exceptions thrown when you call $lh->maketext to get
+messages that aren't in there). But if you were (advisedly) lazy and are
+using an _AUTO lexicon, then you've got to make a list of all the phrases
+that you've so far been letting _AUTO generate for you. There are very
+many ways to assemble such a list. The most straightforward is to simply
+grep the source for every occurrence of "maketext" (or calls
+to wrappers around it, like the above C<pmt> function), and to log the
+following phrase.
+
+=item *
+
+You may at this point want to consider whether your base class
+(Projname::L10N), from which all lexicons inherit from (Projname::L10N::en,
+Projname::L10N::es, etc.), should be an _AUTO lexicon. It may be true
+that in theory, all needed messages will be in each language class;
+but in the presumably unlikely or "impossible" case of lookup failure,
+you should consider whether your program should throw an exception,
+emit text in English (or whatever your project's first language is),
+or some more complex solution as described in the section
+"Controlling Lookup Failure", above.
+
+=item *
+
+Submit all messages/phrases/etc. to translators.
+
+(You may, in fact, want to start with localizing to I<one> other language
+at first, if you're not sure that you've properly abstracted the
+language-dependent parts of your code.)
+
+Translators may request clarification of the situation in which a
+particular phrase is found. For example, in English we are entirely happy
+saying "I<n> files found", regardless of whether we mean "I looked for files,
+and found I<n> of them" or the rather distinct situation of "I looked for
+something else (like lines in files), and along the way I saw I<n>
+files." This may involve rethinking things that you thought quite clear:
+should "Edit" on a toolbar be a noun ("editing") or a verb ("to edit")? Is
+there already a conventionalized way to express that menu option, separate
+from the target language's normal word for "to edit"?
+
+In all cases where the very common phenomenon of quantification
+(saying "I<N> files", for B<any> value of N)
+is involved, each translator should make clear what dependencies the
+number causes in the sentence. In many cases, dependency is
+limited to words adjacent to the number, in places where you might
+expect them ("I found the-?PLURAL I<N>
+empty-?PLURAL directory-?PLURAL"), but in some cases there are
+unexpected dependencies ("I found-?PLURAL ..."!) as well as long-distance
+dependencies "The I<N> directory-?PLURAL could not be deleted-?PLURAL"!).
+
+Remind the translators to consider the case where N is 0:
+"0 files found" isn't exactly natural-sounding in any language, but it
+may be unacceptable in many -- or it may condition special
+kinds of agreement (similar to English "I didN'T find ANY files").
+
+Remember to ask your translators about numeral formatting in their
+language, so that you can override the C<numf> method as
+appropriate. Typical variables in number formatting are: what to
+use as a decimal point (comma? period?); what to use as a thousands
+separator (space? nonbreaking space? comma? period? small
+middot? prime? apostrophe?); and even whether the so-called "thousands
+separator" is actually for every third digit -- I've heard reports of
+two hundred thousand being expressible as "2,00,000" for some Indian
+(Subcontinental) languages, besides the less surprising "S<200 000>",
+"200.000", "200,000", and "200'000". Also, using a set of numeral
+glyphs other than the usual ASCII "0"-"9" might be appreciated, as via
+C<tr/0-9/\x{0966}-\x{096F}/> for getting digits in Devanagari script
+(for Hindi, Konkani, others).
+
+The basic C<quant> method that Locale::Maketext provides should be
+good for many languages. For some languages, it might be useful
+to modify it (or its constituent C<numerate> method)
+to take a plural form in the two-argument call to C<quant>
+(as in "[quant,_1,files]") if
+it's all-around easier to infer the singular form from the plural, than
+to infer the plural form from the singular.
+
+But for other languages (as is discussed at length
+in L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13>), simple
+C<quant>/C<numerify> is not enough. For the particularly problematic
+Slavic languages, what you may need is a method which you provide
+with the number, the citation form of the noun to quantify, and
+the case and gender that the sentence's syntax projects onto that
+noun slot. The method would then be responsible for determining
+what grammatical number that numeral projects onto its noun phrase,
+and what case and gender it may override the normal case and gender
+with; and then it would look up the noun in a lexicon providing
+all needed inflected forms.
+
+=item *
+
+You may also wish to discuss with the translators the question of
+how to relate different subforms of the same language tag,
+considering how this reacts with C<get_handle>'s treatment of
+these. For example, if a user accepts interfaces in "en, fr", and
+you have interfaces available in "en-US" and "fr", what should
+they get? You may wish to resolve this by establishing that "en"
+and "en-US" are effectively synonymous, by having one class
+zero-derive from the other.
+
+For some languages this issue may never come up (Danish is rarely
+expressed as "da-DK", but instead is just "da"). And for other
+languages, the whole concept of a "generic" form may verge on
+being uselessly vague, particularly for interfaces involving voice
+media in forms of Arabic or Chinese.
+
+=item *
+
+Once you've localized your program/site/etc. for all desired
+languages, be sure to show the result (whether live, or via
+screenshots) to the translators. Once they approve, make every
+effort to have it then checked by at least one other speaker of
+that language. This holds true even when (or especially when) the
+translation is done by one of your own programmers. Some
+kinds of systems may be harder to find testers for than others,
+depending on the amount of domain-specific jargon and concepts
+involved -- it's easier to find people who can tell you whether
+they approve of your translation for "delete this message" in an
+email-via-Web interface, than to find people who can give you
+an informed opinion on your translation for "attribute value"
+in an XML query tool's interface.
+
+=back
+
+=head1 SEE ALSO
+
+I recommend reading all of these:
+
+L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13> -- my I<The Perl
+Journal> article about Maketext. It explains many important concepts
+underlying Locale::Maketext's design, and some insight into why
+Maketext is better than the plain old approach of having
+message catalogs that are just databases of sprintf formats.
+
+L<File::Findgrep|File::Findgrep> is a sample application/module
+that uses Locale::Maketext to localize its messages. For a larger
+internationalized system, see also L<Apache::MP3>.
+
+L<I18N::LangTags|I18N::LangTags>.
+
+L<Win32::Locale|Win32::Locale>.
+
+RFC 3066, I<Tags for the Identification of Languages>,
+as at http://sunsite.dk/RFC/rfc/rfc3066.html
+
+RFC 2277, I<IETF Policy on Character Sets and Languages>
+is at http://sunsite.dk/RFC/rfc/rfc2277.html -- much of it is
+just things of interest to protocol designers, but it explains
+some basic concepts, like the distinction between locales and
+language-tags.
+
+The manual for GNU C<gettext>. The gettext dist is available in
+C<ftp://prep.ai.mit.edu/pub/gnu/> -- get
+a recent gettext tarball and look in its "doc/" directory, there's
+an easily browsable HTML version in there. The
+gettext documentation asks lots of questions worth thinking
+about, even if some of their answers are sometimes wonky,
+particularly where they start talking about pluralization.
+
+The Locale/Maketext.pm source. Obverse that the module is much
+shorter than its documentation!
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+Copyright (c) 1999-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.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm b/Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm
new file mode 100644
index 00000000000..9af292c61cc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm
@@ -0,0 +1,328 @@
+package Locale::Maketext::Guts;
+
+$VERSION = '1.13';
+
+BEGIN {
+ # Just so we're nice and define SOMETHING in "our" package.
+ *zorp = sub { return scalar @_ } unless defined &zorp;
+}
+
+package Locale::Maketext;
+use strict;
+use vars qw($USE_LITERALS $GUTSPATH);
+
+BEGIN {
+ $GUTSPATH = __FILE__;
+ *DEBUG = sub () {0} unless defined &DEBUG;
+}
+
+use utf8;
+
+sub _compile {
+ # This big scary routine compiles an entry.
+ # It returns either a coderef if there's brackety bits in this, or
+ # otherwise a ref to a scalar.
+
+ my $target = ref($_[0]) || $_[0];
+
+ my(@code);
+ my(@c) = (''); # "chunks" -- scratch.
+ my $call_count = 0;
+ my $big_pile = '';
+ {
+ my $in_group = 0; # start out outside a group
+ my($m, @params); # scratch
+
+ while($_[1] =~ # Iterate over chunks.
+ m/\G(
+ [^\~\[\]]+ # non-~[] stuff
+ |
+ ~. # ~[, ~], ~~, ~other
+ |
+ \[ # [ presumably opening a group
+ |
+ \] # ] presumably closing a group
+ |
+ ~ # terminal ~ ?
+ |
+ $
+ )/xgs
+ ) {
+ DEBUG>2 and print qq{ "$1"\n};
+
+ if($1 eq '[' or $1 eq '') { # "[" or end
+ # Whether this is "[" or end, force processing of any
+ # preceding literal.
+ if($in_group) {
+ if($1 eq '') {
+ $target->_die_pointing($_[1], 'Unterminated bracket group');
+ }
+ else {
+ $target->_die_pointing($_[1], 'You can\'t nest bracket groups');
+ }
+ }
+ else {
+ if ($1 eq '') {
+ DEBUG>2 and print " [end-string]\n";
+ }
+ else {
+ $in_group = 1;
+ }
+ die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
+ if(length $c[-1]) {
+ # Now actually processing the preceding literal
+ $big_pile .= $c[-1];
+ if($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $c[-1] !~ m/[^\x20-\x7E]/s
+ # ASCII very safe chars
+ : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # normal case -- all very safe chars
+ $c[-1] =~ s/'/\\'/g;
+ push @code, q{ '} . $c[-1] . "',\n";
+ $c[-1] = ''; # reuse this slot
+ }
+ else {
+ push @code, ' $c[' . $#c . "],\n";
+ push @c, ''; # new chunk
+ }
+ }
+ # else just ignore the empty string.
+ }
+
+ }
+ elsif($1 eq ']') { # "]"
+ # close group -- go back in-band
+ if($in_group) {
+ $in_group = 0;
+
+ DEBUG>2 and print " --Closing group [$c[-1]]\n";
+
+ # And now process the group...
+
+ if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
+ DEBUG > 2 and print " -- (Ignoring)\n";
+ $c[-1] = ''; # reset out chink
+ next;
+ }
+
+ #$c[-1] =~ s/^\s+//s;
+ #$c[-1] =~ s/\s+$//s;
+ ($m,@params) = split(/,/, $c[-1], -1); # was /\s*,\s*/
+
+ # A bit of a hack -- we've turned "~,"'s into DELs, so turn
+ # 'em into real commas here.
+ if (ord('A') == 65) { # ASCII, etc
+ foreach($m, @params) { tr/\x7F/,/ }
+ }
+ else { # EBCDIC (1047, 0037, POSIX-BC)
+ # Thanks to Peter Prymmer for the EBCDIC handling
+ foreach($m, @params) { tr/\x07/,/ }
+ }
+
+ # Special-case handling of some method names:
+ if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) {
+ # Treat [_1,...] as [,_1,...], etc.
+ unshift @params, $m;
+ $m = '';
+ }
+ elsif($m eq '*') {
+ $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
+ }
+ elsif($m eq '#') {
+ $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
+ }
+
+ # Most common case: a simple, legal-looking method name
+ if($m eq '') {
+ # 0-length method name means to just interpolate:
+ push @code, ' (';
+ }
+ elsif($m =~ /^\w+(?:\:\:\w+)*$/s
+ and $m !~ m/(?:^|\:)\d/s
+ # exclude starting a (sub)package or symbol with a digit
+ ) {
+ # Yes, it even supports the demented (and undocumented?)
+ # $obj->Foo::bar(...) syntax.
+ $target->_die_pointing(
+ $_[1], q{Can't use "SUPER::" in a bracket-group method},
+ 2 + length($c[-1])
+ )
+ if $m =~ m/^SUPER::/s;
+ # Because for SUPER:: to work, we'd have to compile this into
+ # the right package, and that seems just not worth the bother,
+ # unless someone convinces me otherwise.
+
+ push @code, ' $_[0]->' . $m . '(';
+ }
+ else {
+ # TODO: implement something? or just too icky to consider?
+ $target->_die_pointing(
+ $_[1],
+ "Can't use \"$m\" as a method name in bracket group",
+ 2 + length($c[-1])
+ );
+ }
+
+ pop @c; # we don't need that chunk anymore
+ ++$call_count;
+
+ foreach my $p (@params) {
+ if($p eq '_*') {
+ # Meaning: all parameters except $_[0]
+ $code[-1] .= ' @_[1 .. $#_], ';
+ # and yes, that does the right thing for all @_ < 3
+ }
+ elsif($p =~ m/^_(-?\d+)$/s) {
+ # _3 meaning $_[3]
+ $code[-1] .= '$_[' . (0 + $1) . '], ';
+ }
+ elsif($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $p !~ m/[^\x20-\x7E]/s
+ # ASCII very safe chars
+ : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # Normal case: a literal containing only safe characters
+ $p =~ s/'/\\'/g;
+ $code[-1] .= q{'} . $p . q{', };
+ }
+ else {
+ # Stow it on the chunk-stack, and just refer to that.
+ push @c, $p;
+ push @code, ' $c[' . $#c . '], ';
+ }
+ }
+ $code[-1] .= "),\n";
+
+ push @c, '';
+ }
+ else {
+ $target->_die_pointing($_[1], q{Unbalanced ']'});
+ }
+
+ }
+ elsif(substr($1,0,1) ne '~') {
+ # it's stuff not containing "~" or "[" or "]"
+ # i.e., a literal blob
+ $c[-1] .= $1;
+
+ }
+ elsif($1 eq '~~') { # "~~"
+ $c[-1] .= '~';
+
+ }
+ elsif($1 eq '~[') { # "~["
+ $c[-1] .= '[';
+
+ }
+ elsif($1 eq '~]') { # "~]"
+ $c[-1] .= ']';
+
+ }
+ elsif($1 eq '~,') { # "~,"
+ if($in_group) {
+ # This is a hack, based on the assumption that no-one will actually
+ # want a DEL inside a bracket group. Let's hope that's it's true.
+ if (ord('A') == 65) { # ASCII etc
+ $c[-1] .= "\x7F";
+ }
+ else { # EBCDIC (cp 1047, 0037, POSIX-BC)
+ $c[-1] .= "\x07";
+ }
+ }
+ else {
+ $c[-1] .= '~,';
+ }
+
+ }
+ elsif($1 eq '~') { # possible only at string-end, it seems.
+ $c[-1] .= '~';
+
+ }
+ else {
+ # It's a "~X" where X is not a special character.
+ # Consider it a literal ~ and X.
+ $c[-1] .= $1;
+ }
+ }
+ }
+
+ if($call_count) {
+ undef $big_pile; # Well, nevermind that.
+ }
+ else {
+ # It's all literals! Ahwell, that can happen.
+ # So don't bother with the eval. Return a SCALAR reference.
+ return \$big_pile;
+ }
+
+ die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity
+ DEBUG and warn scalar(@c), " chunks under closure\n";
+ if(@code == 0) { # not possible?
+ DEBUG and warn "Empty code\n";
+ return \'';
+ }
+ elsif(@code > 1) { # most cases, presumably!
+ unshift @code, "join '',\n";
+ }
+ unshift @code, "use strict; sub {\n";
+ push @code, "}\n";
+
+ DEBUG and warn @code;
+ my $sub = eval(join '', @code);
+ die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
+ return $sub;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _die_pointing {
+ # This is used by _compile to throw a fatal error
+ my $target = shift; # class name
+ # ...leaving $_[0] the error-causing text, and $_[1] the error message
+
+ my $i = index($_[0], "\n");
+
+ my $pointy;
+ my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
+ if($pos < 1) {
+ $pointy = "^=== near there\n";
+ }
+ else { # we need to space over
+ my $first_tab = index($_[0], "\t");
+ if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
+ # No tabs, or the first tab is harmlessly after where we will point to,
+ # AND we're far enough from the margin that we can draw a proper arrow.
+ $pointy = ('=' x $pos) . "^ near there\n";
+ }
+ else {
+ # tabs screw everything up!
+ $pointy = substr($_[0],0,$pos);
+ $pointy =~ tr/\t //cd;
+ # make everything into whitespace, but preseving tabs
+ $pointy .= "^=== near there\n";
+ }
+ }
+
+ my $errmsg = "$_[1], in\:\n$_[0]";
+
+ if($i == -1) {
+ # No newline.
+ $errmsg .= "\n" . $pointy;
+ }
+ elsif($i == (length($_[0]) - 1) ) {
+ # Already has a newline at end.
+ $errmsg .= $pointy;
+ }
+ else {
+ # don't bother with the pointy bit, I guess.
+ }
+ Carp::croak( "$errmsg via $target, as used" );
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm b/Master/tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm
new file mode 100644
index 00000000000..daa9840260a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm
@@ -0,0 +1,49 @@
+package Locale::Maketext::GutsLoader;
+
+$VERSION = '1.13';
+
+use strict;
+sub zorp { return scalar @_ }
+
+BEGIN {
+ $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
+ *Locale::Maketext::DEBUG = sub () {0}
+ unless defined &Locale::Maketext::DEBUG;
+}
+
+#
+# This whole drama is so that we can load the utf8'd code
+# in Locale::Maketext::Guts, but if that fails, snip the
+# utf8 and then try THAT.
+#
+
+$Locale::Maketext::GUTSPATH = '';
+Locale::Maketext::DEBUG and warn "Requiring Locale::Maketext::Guts...\n";
+eval 'require Locale::Maketext::Guts';
+
+if ($@) {
+ my $path = $Locale::Maketext::GUTSPATH;
+
+ die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
+
+ die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
+ unless -e $path and -f _ and -r _;
+
+ open(IN, $path) or die "Can't read-open $path\nAborting";
+
+ my $source;
+ { local $/; $source = <IN>; }
+ close(IN);
+ unless( $source =~ s/\b(use utf8)/# $1/ ) {
+ Locale::Maketext::DEBUG and
+ print "I didn't see 'use utf8' in $path\n";
+ }
+ eval $source;
+ die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@;
+ Locale::Maketext::DEBUG and warn "Non-utf8'd Locale::Maketext::Guts fine\n";
+}
+else {
+ Locale::Maketext::DEBUG and warn "Loaded Locale::Maketext::Guts fine\n";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm b/Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm
new file mode 100644
index 00000000000..30760f3c26d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm
@@ -0,0 +1,341 @@
+package Locale::Maketext::Simple;
+$Locale::Maketext::Simple::VERSION = '0.21';
+
+use strict;
+use 5.005;
+
+=head1 NAME
+
+Locale::Maketext::Simple - Simple interface to Locale::Maketext::Lexicon
+
+=head1 VERSION
+
+This document describes version 0.18 of Locale::Maketext::Simple,
+released Septermber 8, 2006.
+
+=head1 SYNOPSIS
+
+Minimal setup (looks for F<auto/Foo/*.po> and F<auto/Foo/*.mo>):
+
+ package Foo;
+ use Locale::Maketext::Simple; # exports 'loc'
+ loc_lang('fr'); # set language to French
+ sub hello {
+ print loc("Hello, [_1]!", "World");
+ }
+
+More sophisticated example:
+
+ package Foo::Bar;
+ use Locale::Maketext::Simple (
+ Class => 'Foo', # search in auto/Foo/
+ Style => 'gettext', # %1 instead of [_1]
+ Export => 'maketext', # maketext() instead of loc()
+ Subclass => 'L10N', # Foo::L10N instead of Foo::I18N
+ Decode => 1, # decode entries to unicode-strings
+ Encoding => 'locale', # but encode lexicons in current locale
+ # (needs Locale::Maketext::Lexicon 0.36)
+ );
+ sub japh {
+ print maketext("Just another %1 hacker", "Perl");
+ }
+
+=head1 DESCRIPTION
+
+This module is a simple wrapper around B<Locale::Maketext::Lexicon>,
+designed to alleviate the need of creating I<Language Classes> for
+module authors.
+
+The language used is chosen from the loc_lang call. If a lookup is not
+possible, the i-default language will be used. If the lookup is not in the
+i-default language, then the key will be returned.
+
+If B<Locale::Maketext::Lexicon> is not present, it implements a
+minimal localization function by simply interpolating C<[_1]> with
+the first argument, C<[_2]> with the second, etc. Interpolated
+function like C<[quant,_1]> are treated as C<[_1]>, with the sole
+exception of C<[tense,_1,X]>, which will append C<ing> to C<_1> when
+X is C<present>, or appending C<ed> to <_1> otherwise.
+
+=head1 OPTIONS
+
+All options are passed either via the C<use> statement, or via an
+explicit C<import>.
+
+=head2 Class
+
+By default, B<Locale::Maketext::Simple> draws its source from the
+calling package's F<auto/> directory; you can override this behaviour
+by explicitly specifying another package as C<Class>.
+
+=head2 Path
+
+If your PO and MO files are under a path elsewhere than C<auto/>,
+you may specify it using the C<Path> option.
+
+=head2 Style
+
+By default, this module uses the C<maketext> style of C<[_1]> and
+C<[quant,_1]> for interpolation. Alternatively, you can specify the
+C<gettext> style, which uses C<%1> and C<%quant(%1)> for interpolation.
+
+This option is case-insensitive.
+
+=head2 Export
+
+By default, this module exports a single function, C<loc>, into its
+caller's namespace. You can set it to another name, or set it to
+an empty string to disable exporting.
+
+=head2 Subclass
+
+By default, this module creates an C<::I18N> subclass under the
+caller's package (or the package specified by C<Class>), and stores
+lexicon data in its subclasses. You can assign a name other than
+C<I18N> via this option.
+
+=head2 Decode
+
+If set to a true value, source entries will be converted into
+utf8-strings (available in Perl 5.6.1 or later). This feature
+needs the B<Encode> or B<Encode::compat> module.
+
+=head2 Encoding
+
+Specifies an encoding to store lexicon entries, instead of
+utf8-strings. If set to C<locale>, the encoding from the current
+locale setting is used. Implies a true value for C<Decode>.
+
+=cut
+
+sub import {
+ my ($class, %args) = @_;
+
+ $args{Class} ||= caller;
+ $args{Style} ||= 'maketext';
+ $args{Export} ||= 'loc';
+ $args{Subclass} ||= 'I18N';
+
+ my ($loc, $loc_lang) = $class->load_loc(%args);
+ $loc ||= $class->default_loc(%args);
+
+ no strict 'refs';
+ *{caller(0) . "::$args{Export}"} = $loc if $args{Export};
+ *{caller(0) . "::$args{Export}_lang"} = $loc_lang || sub { 1 };
+}
+
+my %Loc;
+
+sub reload_loc { %Loc = () }
+
+sub load_loc {
+ my ($class, %args) = @_;
+
+ my $pkg = join('::', grep { defined and length } $args{Class}, $args{Subclass});
+ return $Loc{$pkg} if exists $Loc{$pkg};
+
+ eval { require Locale::Maketext::Lexicon; 1 } or return;
+ $Locale::Maketext::Lexicon::VERSION > 0.20 or return;
+ eval { require File::Spec; 1 } or return;
+
+ my $path = $args{Path} || $class->auto_path($args{Class}) or return;
+ my $pattern = File::Spec->catfile($path, '*.[pm]o');
+ my $decode = $args{Decode} || 0;
+ my $encoding = $args{Encoding} || undef;
+
+ $decode = 1 if $encoding;
+
+ $pattern =~ s{\\}{/}g; # to counter win32 paths
+
+ eval "
+ package $pkg;
+ use base 'Locale::Maketext';
+ Locale::Maketext::Lexicon->import({
+ 'i-default' => [ 'Auto' ],
+ '*' => [ Gettext => \$pattern ],
+ _decode => \$decode,
+ _encoding => \$encoding,
+ });
+ *${pkg}::Lexicon = \\%${pkg}::i_default::Lexicon;
+ *tense = sub { \$_[1] . ((\$_[2] eq 'present') ? 'ing' : 'ed') }
+ unless defined &tense;
+
+ 1;
+ " or die $@;
+
+ my $lh = eval { $pkg->get_handle } or return;
+ my $style = lc($args{Style});
+ if ($style eq 'maketext') {
+ $Loc{$pkg} = sub {
+ $lh->maketext(@_)
+ };
+ }
+ elsif ($style eq 'gettext') {
+ $Loc{$pkg} = sub {
+ my $str = shift;
+ $str =~ s{([\~\[\]])}{~$1}g;
+ $str =~ s{
+ ([%\\]%) # 1 - escaped sequence
+ |
+ % (?:
+ ([A-Za-z#*]\w*) # 2 - function call
+ \(([^\)]*)\) # 3 - arguments
+ |
+ ([1-9]\d*|\*) # 4 - variable
+ )
+ }{
+ $1 ? $1
+ : $2 ? "\[$2,"._unescape($3)."]"
+ : "[_$4]"
+ }egx;
+ return $lh->maketext($str, @_);
+ };
+ }
+ else {
+ die "Unknown Style: $style";
+ }
+
+ return $Loc{$pkg}, sub {
+ $lh = $pkg->get_handle(@_);
+ };
+}
+
+sub default_loc {
+ my ($self, %args) = @_;
+ my $style = lc($args{Style});
+ if ($style eq 'maketext') {
+ return sub {
+ my $str = shift;
+ $str =~ s{((?<!~)(?:~~)*)\[_([1-9]\d*|\*)\]}
+ {$1%$2}g;
+ $str =~ s{((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]}
+ {"$1%$2(" . _escape($3) . ')'}eg;
+ _default_gettext($str, @_);
+ };
+ }
+ elsif ($style eq 'gettext') {
+ return \&_default_gettext;
+ }
+ else {
+ die "Unknown Style: $style";
+ }
+}
+
+sub _default_gettext {
+ my $str = shift;
+ $str =~ s{
+ % # leading symbol
+ (?: # either one of
+ \d+ # a digit, like %1
+ | # or
+ (\w+)\( # a function call -- 1
+ (?: # either
+ %\d+ # an interpolation
+ | # or
+ ([^,]*) # some string -- 2
+ ) # end either
+ (?: # maybe followed
+ , # by a comma
+ ([^),]*) # and a param -- 3
+ )? # end maybe
+ (?: # maybe followed
+ , # by another comma
+ ([^),]*) # and a param -- 4
+ )? # end maybe
+ [^)]* # and other ignorable params
+ \) # closing function call
+ ) # closing either one of
+ }{
+ my $digit = $2 || shift;
+ $digit . (
+ $1 ? (
+ ($1 eq 'tense') ? (($3 eq 'present') ? 'ing' : 'ed') :
+ ($1 eq 'quant') ? ' ' . (($digit > 1) ? ($4 || "$3s") : $3) :
+ ''
+ ) : ''
+ );
+ }egx;
+ return $str;
+};
+
+sub _escape {
+ my $text = shift;
+ $text =~ s/\b_([1-9]\d*)/%$1/g;
+ return $text;
+}
+
+sub _unescape {
+ join(',', map {
+ /\A(\s*)%([1-9]\d*|\*)(\s*)\z/ ? "$1_$2$3" : $_
+ } split(/,/, $_[0]));
+}
+
+sub auto_path {
+ my ($self, $calldir) = @_;
+ $calldir =~ s#::#/#g;
+ my $path = $INC{$calldir . '.pm'} or return;
+
+ # Try absolute path name.
+ if ($^O eq 'MacOS') {
+ (my $malldir = $calldir) =~ tr#/#:#;
+ $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:#s;
+ } else {
+ $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/#;
+ }
+
+ return $path if -d $path;
+
+ # If that failed, try relative path with normal @INC searching.
+ $path = "auto/$calldir/";
+ foreach my $inc (@INC) {
+ return "$inc/$path" if -d "$inc/$path";
+ }
+
+ return;
+}
+
+1;
+
+=head1 ACKNOWLEDGMENTS
+
+Thanks to Jos I. Boumans for suggesting this module to be written.
+
+Thanks to Chia-Liang Kao for suggesting C<Path> and C<loc_lang>.
+
+=head1 SEE ALSO
+
+L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2003, 2004, 2005, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This software is released under the MIT license cited below. Additionally,
+when this software is distributed with B<Perl Kit, Version 5>, you may also
+redistribute it and/or modify it under the same terms as Perl itself.
+
+=head2 The "MIT" License
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod b/Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod
new file mode 100644
index 00000000000..b5e2c0b972b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod
@@ -0,0 +1,775 @@
+# This document contains text in Perl "POD" format.
+# Use a POD viewer like perldoc or perlman to render it.
+
+=head1 NAME
+
+Locale::Maketext::TPJ13 -- article about software localization
+
+=head1 SYNOPSIS
+
+ # This an article, not a module.
+
+=head1 DESCRIPTION
+
+The following article by Sean M. Burke and Jordan Lachler
+first appeared in I<The Perl Journal> #13
+and is copyright 1999 The Perl Journal. It appears
+courtesy of Jon Orwant and The Perl Journal. This document may be
+distributed under the same terms as Perl itself.
+
+=head1 Localization and Perl: gettext breaks, Maketext fixes
+
+by Sean M. Burke and Jordan Lachler
+
+This article points out cases where gettext (a common system for
+localizing software interfaces -- i.e., making them work in the user's
+language of choice) fails because of basic differences between human
+languages. This article then describes Maketext, a new system capable
+of correctly treating these differences.
+
+=head2 A Localization Horror Story: It Could Happen To You
+
+=over
+
+"There are a number of languages spoken by human beings in this
+world."
+
+-- Harald Tveit Alvestrand, in RFC 1766, "Tags for the
+Identification of Languages"
+
+=back
+
+Imagine that your task for the day is to localize a piece of software
+-- and luckily for you, the only output the program emits is two
+messages, like this:
+
+ I scanned 12 directories.
+
+ Your query matched 10 files in 4 directories.
+
+So how hard could that be? You look at the code that
+produces the first item, and it reads:
+
+ printf("I scanned %g directories.",
+ $directory_count);
+
+You think about that, and realize that it doesn't even work right for
+English, as it can produce this output:
+
+ I scanned 1 directories.
+
+So you rewrite it to read:
+
+ printf("I scanned %g %s.",
+ $directory_count,
+ $directory_count == 1 ?
+ "directory" : "directories",
+ );
+
+...which does the Right Thing. (In case you don't recall, "%g" is for
+locale-specific number interpolation, and "%s" is for string
+interpolation.)
+
+But you still have to localize it for all the languages you're
+producing this software for, so you pull Locale::gettext off of CPAN
+so you can access the C<gettext> C functions you've heard are standard
+for localization tasks.
+
+And you write:
+
+ printf(gettext("I scanned %g %s."),
+ $dir_scan_count,
+ $dir_scan_count == 1 ?
+ gettext("directory") : gettext("directories"),
+ );
+
+But you then read in the gettext manual (Drepper, Miller, and Pinard 1995)
+that this is not a good idea, since how a single word like "directory"
+or "directories" is translated may depend on context -- and this is
+true, since in a case language like German or Russian, you'd may need
+these words with a different case ending in the first instance (where the
+word is the object of a verb) than in the second instance, which you haven't even
+gotten to yet (where the word is the object of a preposition, "in %g
+directories") -- assuming these keep the same syntax when translated
+into those languages.
+
+So, on the advice of the gettext manual, you rewrite:
+
+ printf( $dir_scan_count == 1 ?
+ gettext("I scanned %g directory.") :
+ gettext("I scanned %g directories."),
+ $dir_scan_count );
+
+So, you email your various translators (the boss decides that the
+languages du jour are Chinese, Arabic, Russian, and Italian, so you
+have one translator for each), asking for translations for "I scanned
+%g directory." and "I scanned %g directories.". When they reply,
+you'll put that in the lexicons for gettext to use when it localizes
+your software, so that when the user is running under the "zh"
+(Chinese) locale, gettext("I scanned %g directory.") will return the
+appropriate Chinese text, with a "%g" in there where printf can then
+interpolate $dir_scan.
+
+Your Chinese translator emails right back -- he says both of these
+phrases translate to the same thing in Chinese, because, in linguistic
+jargon, Chinese "doesn't have number as a grammatical category" --
+whereas English does. That is, English has grammatical rules that
+refer to "number", i.e., whether something is grammatically singular
+or plural; and one of these rules is the one that forces nouns to take
+a plural suffix (generally "s") when in a plural context, as they are when
+they follow a number other than "one" (including, oddly enough, "zero").
+Chinese has no such rules, and so has just the one phrase where English
+has two. But, no problem, you can have this one Chinese phrase appear
+as the translation for the two English phrases in the "zh" gettext
+lexicon for your program.
+
+Emboldened by this, you dive into the second phrase that your software
+needs to output: "Your query matched 10 files in 4 directories.". You notice
+that if you want to treat phrases as indivisible, as the gettext
+manual wisely advises, you need four cases now, instead of two, to
+cover the permutations of singular and plural on the two items,
+$dir_count and $file_count. So you try this:
+
+ printf( $file_count == 1 ?
+ ( $directory_count == 1 ?
+ gettext("Your query matched %g file in %g directory.") :
+ gettext("Your query matched %g file in %g directories.") ) :
+ ( $directory_count == 1 ?
+ gettext("Your query matched %g files in %g directory.") :
+ gettext("Your query matched %g files in %g directories.") ),
+ $file_count, $directory_count,
+ );
+
+(The case of "1 file in 2 [or more] directories" could, I suppose,
+occur in the case of symlinking or something of the sort.)
+
+It occurs to you that this is not the prettiest code you've ever
+written, but this seems the way to go. You mail off to the
+translators asking for translations for these four cases. The
+Chinese guy replies with the one phrase that these all translate to in
+Chinese, and that phrase has two "%g"s in it, as it should -- but
+there's a problem. He translates it word-for-word back: "In %g
+directories contains %g files match your query." The %g
+slots are in an order reverse to what they are in English. You wonder
+how you'll get gettext to handle that.
+
+But you put it aside for the moment, and optimistically hope that the
+other translators won't have this problem, and that their languages
+will be better behaved -- i.e., that they will be just like English.
+
+But the Arabic translator is the next to write back. First off, your
+code for "I scanned %g directory." or "I scanned %g directories."
+assumes there's only singular or plural. But, to use linguistic
+jargon again, Arabic has grammatical number, like English (but unlike
+Chinese), but it's a three-term category: singular, dual, and plural.
+In other words, the way you say "directory" depends on whether there's
+one directory, or I<two> of them, or I<more than two> of them. Your
+test of C<($directory == 1)> no longer does the job. And it means
+that where English's grammatical category of number necessitates
+only the two permutations of the first sentence based on "directory
+[singular]" and "directories [plural]", Arabic has three -- and,
+worse, in the second sentence ("Your query matched %g file in %g
+directory."), where English has four, Arabic has nine. You sense
+an unwelcome, exponential trend taking shape.
+
+Your Italian translator emails you back and says that "I searched 0
+directories" (a possible English output of your program) is stilted,
+and if you think that's fine English, that's your problem, but that
+I<just will not do> in the language of Dante. He insists that where
+$directory_count is 0, your program should produce the Italian text
+for "I I<didn't> scan I<any> directories.". And ditto for "I didn't
+match any files in any directories", although he says the last part
+about "in any directories" should probably just be left off.
+
+You wonder how you'll get gettext to handle this; to accomodate the
+ways Arabic, Chinese, and Italian deal with numbers in just these few
+very simple phrases, you need to write code that will ask gettext for
+different queries depending on whether the numerical values in
+question are 1, 2, more than 2, or in some cases 0, and you still haven't
+figured out the problem with the different word order in Chinese.
+
+Then your Russian translator calls on the phone, to I<personally> tell
+you the bad news about how really unpleasant your life is about to
+become:
+
+Russian, like German or Latin, is an inflectional language; that is, nouns
+and adjectives have to take endings that depend on their case
+(i.e., nominative, accusative, genitive, etc...) -- which is roughly a matter of
+what role they have in syntax of the sentence --
+as well as on the grammatical gender (i.e., masculine, feminine, neuter)
+and number (i.e., singular or plural) of the noun, as well as on the
+declension class of the noun. But unlike with most other inflected languages,
+putting a number-phrase (like "ten" or "forty-three", or their Arabic
+numeral equivalents) in front of noun in Russian can change the case and
+number that noun is, and therefore the endings you have to put on it.
+
+He elaborates: In "I scanned %g directories", you'd I<expect>
+"directories" to be in the accusative case (since it is the direct
+object in the sentence) and the plural number,
+except where $directory_count is 1, then you'd expect the singular, of
+course. Just like Latin or German. I<But!> Where $directory_count %
+10 is 1 ("%" for modulo, remember), assuming $directory count is an
+integer, and except where $directory_count % 100 is 11, "directories"
+is forced to become grammatically singular, which means it gets the
+ending for the accusative singular... You begin to visualize the code
+it'd take to test for the problem so far, I<and still work for Chinese
+and Arabic and Italian>, and how many gettext items that'd take, but
+he keeps going... But where $directory_count % 10 is 2, 3, or 4
+(except where $directory_count % 100 is 12, 13, or 14), the word for
+"directories" is forced to be genitive singular -- which means another
+ending... The room begins to spin around you, slowly at first... But
+with I<all other> integer values, since "directory" is an inanimate
+noun, when preceded by a number and in the nominative or accusative
+cases (as it is here, just your luck!), it does stay plural, but it is
+forced into the genitive case -- yet another ending... And
+you never hear him get to the part about how you're going to run into
+similar (but maybe subtly different) problems with other Slavic
+languages like Polish, because the floor comes up to meet you, and you
+fade into unconsciousness.
+
+
+The above cautionary tale relates how an attempt at localization can
+lead from programmer consternation, to program obfuscation, to a need
+for sedation. But careful evaluation shows that your choice of tools
+merely needed further consideration.
+
+=head2 The Linguistic View
+
+=over
+
+"It is more complicated than you think."
+
+-- The Eighth Networking Truth, from RFC 1925
+
+=back
+
+The field of Linguistics has expended a great deal of effort over the
+past century trying to find grammatical patterns which hold across
+languages; it's been a constant process
+of people making generalizations that should apply to all languages,
+only to find out that, all too often, these generalizations fail --
+sometimes failing for just a few languages, sometimes whole classes of
+languages, and sometimes nearly every language in the world except
+English. Broad statistical trends are evident in what the "average
+language" is like as far as what its rules can look like, must look
+like, and cannot look like. But the "average language" is just as
+unreal a concept as the "average person" -- it runs up against the
+fact no language (or person) is, in fact, average. The wisdom of past
+experience leads us to believe that any given language can do whatever
+it wants, in any order, with appeal to any kind of grammatical
+categories wants -- case, number, tense, real or metaphoric
+characteristics of the things that words refer to, arbitrary or
+predictable classifications of words based on what endings or prefixes
+they can take, degree or means of certainty about the truth of
+statements expressed, and so on, ad infinitum.
+
+Mercifully, most localization tasks are a matter of finding ways to
+translate whole phrases, generally sentences, where the context is
+relatively set, and where the only variation in content is I<usually>
+in a number being expressed -- as in the example sentences above.
+Translating specific, fully-formed sentences is, in practice, fairly
+foolproof -- which is good, because that's what's in the phrasebooks
+that so many tourists rely on. Now, a given phrase (whether in a
+phrasebook or in a gettext lexicon) in one language I<might> have a
+greater or lesser applicability than that phrase's translation into
+another language -- for example, strictly speaking, in Arabic, the
+"your" in "Your query matched..." would take a different form
+depending on whether the user is male or female; so the Arabic
+translation "your[feminine] query" is applicable in fewer cases than
+the corresponding English phrase, which doesn't distinguish the user's
+gender. (In practice, it's not feasable to have a program know the
+user's gender, so the masculine "you" in Arabic is usually used, by
+default.)
+
+But in general, such surprises are rare when entire sentences are
+being translated, especially when the functional context is restricted
+to that of a computer interacting with a user either to convey a fact
+or to prompt for a piece of information. So, for purposes of
+localization, translation by phrase (generally by sentence) is both the
+simplest and the least problematic.
+
+=head2 Breaking gettext
+
+=over
+
+"It Has To Work."
+
+-- First Networking Truth, RFC 1925
+
+=back
+
+Consider that sentences in a tourist phrasebook are of two types: ones
+like "How do I get to the marketplace?" that don't have any blanks to
+fill in, and ones like "How much do these ___ cost?", where there's
+one or more blanks to fill in (and these are usually linked to a
+list of words that you can put in that blank: "fish", "potatoes",
+"tomatoes", etc.) The ones with no blanks are no problem, but the
+fill-in-the-blank ones may not be really straightforward. If it's a
+Swahili phrasebook, for example, the authors probably didn't bother to
+tell you the complicated ways that the verb "cost" changes its
+inflectional prefix depending on the noun you're putting in the blank.
+The trader in the marketplace will still understand what you're saying if
+you say "how much do these potatoes cost?" with the wrong
+inflectional prefix on "cost". After all, I<you> can't speak proper Swahili,
+I<you're> just a tourist. But while tourists can be stupid, computers
+are supposed to be smart; the computer should be able to fill in the
+blank, and still have the results be grammatical.
+
+In other words, a phrasebook entry takes some values as parameters
+(the things that you fill in the blank or blanks), and provides a value
+based on these parameters, where the way you get that final value from
+the given values can, properly speaking, involve an arbitrarily
+complex series of operations. (In the case of Chinese, it'd be not at
+all complex, at least in cases like the examples at the beginning of
+this article; whereas in the case of Russian it'd be a rather complex
+series of operations. And in some languages, the
+complexity could be spread around differently: while the act of
+putting a number-expression in front of a noun phrase might not be
+complex by itself, it may change how you have to, for example, inflect
+a verb elsewhere in the sentence. This is what in syntax is called
+"long-distance dependencies".)
+
+This talk of parameters and arbitrary complexity is just another way
+to say that an entry in a phrasebook is what in a programming language
+would be called a "function". Just so you don't miss it, this is the
+crux of this article: I<A phrase is a function; a phrasebook is a
+bunch of functions.>
+
+The reason that using gettext runs into walls (as in the above
+second-person horror story) is that you're trying to use a string (or
+worse, a choice among a bunch of strings) to do what you really need a
+function for -- which is futile. Preforming (s)printf interpolation
+on the strings which you get back from gettext does allow you to do I<some>
+common things passably well... sometimes... sort of; but, to paraphrase
+what some people say about C<csh> script programming, "it fools you
+into thinking you can use it for real things, but you can't, and you
+don't discover this until you've already spent too much time trying,
+and by then it's too late."
+
+=head2 Replacing gettext
+
+So, what needs to replace gettext is a system that supports lexicons
+of functions instead of lexicons of strings. An entry in a lexicon
+from such a system should I<not> look like this:
+
+ "J'ai trouv\xE9 %g fichiers dans %g r\xE9pertoires"
+
+[\xE9 is e-acute in Latin-1. Some pod renderers would
+scream if I used the actual character here. -- SB]
+
+but instead like this, bearing in mind that this is just a first stab:
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = sprintf("%g %s", $files,
+ $files == 1 ? 'fichier' : 'fichiers');
+ $dirs = sprintf("%g %s", $dirs,
+ $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+Now, there's no particularly obvious way to store anything but strings
+in a gettext lexicon; so it looks like we just have to start over and
+make something better, from scratch. I call my shot at a
+gettext-replacement system "Maketext", or, in CPAN terms,
+Locale::Maketext.
+
+When designing Maketext, I chose to plan its main features in terms of
+"buzzword compliance". And here are the buzzwords:
+
+=head2 Buzzwords: Abstraction and Encapsulation
+
+The complexity of the language you're trying to output a phrase in is
+entirely abstracted inside (and encapsulated within) the Maketext module
+for that interface. When you call:
+
+ print $lang->maketext("You have [quant,_1,piece] of new mail.",
+ scalar(@messages));
+
+you don't know (and in fact can't easily find out) whether this will
+involve lots of figuring, as in Russian (if $lang is a handle to the
+Russian module), or relatively little, as in Chinese. That kind of
+abstraction and encapsulation may encourage other pleasant buzzwords
+like modularization and stratification, depending on what design
+decisions you make.
+
+=head2 Buzzword: Isomorphism
+
+"Isomorphism" means "having the same structure or form"; in discussions
+of program design, the word takes on the special, specific meaning that
+your implementation of a solution to a problem I<has the same
+structure> as, say, an informal verbal description of the solution, or
+maybe of the problem itself. Isomorphism is, all things considered,
+a good thing -- it's what problem-solving (and solution-implementing)
+should look like.
+
+What's wrong the with gettext-using code like this...
+
+ printf( $file_count == 1 ?
+ ( $directory_count == 1 ?
+ "Your query matched %g file in %g directory." :
+ "Your query matched %g file in %g directories." ) :
+ ( $directory_count == 1 ?
+ "Your query matched %g files in %g directory." :
+ "Your query matched %g files in %g directories." ),
+ $file_count, $directory_count,
+ );
+
+is first off that it's not well abstracted -- these ways of testing
+for grammatical number (as in the expressions like C<foo == 1 ?
+singular_form : plural_form>) should be abstracted to each language
+module, since how you get grammatical number is language-specific.
+
+But second off, it's not isomorphic -- the "solution" (i.e., the
+phrasebook entries) for Chinese maps from these four English phrases to
+the one Chinese phrase that fits for all of them. In other words, the
+informal solution would be "The way to say what you want in Chinese is
+with the one phrase 'For your question, in Y directories you would
+find X files'" -- and so the implemented solution should be,
+isomorphically, just a straightforward way to spit out that one
+phrase, with numerals properly interpolated. It shouldn't have to map
+from the complexity of other languages to the simplicity of this one.
+
+=head2 Buzzword: Inheritance
+
+There's a great deal of reuse possible for sharing of phrases between
+modules for related dialects, or for sharing of auxiliary functions
+between related languages. (By "auxiliary functions", I mean
+functions that don't produce phrase-text, but which, say, return an
+answer to "does this number require a plural noun after it?". Such
+auxiliary functions would be used in the internal logic of functions
+that actually do produce phrase-text.)
+
+In the case of sharing phrases, consider that you have an interface
+already localized for American English (probably by having been
+written with that as the native locale, but that's incidental).
+Localizing it for UK English should, in practical terms, be just a
+matter of running it past a British person with the instructions to
+indicate what few phrases would benefit from a change in spelling or
+possibly minor rewording. In that case, you should be able to put in
+the UK English localization module I<only> those phrases that are
+UK-specific, and for all the rest, I<inherit> from the American
+English module. (And I expect this same situation would apply with
+Brazilian and Continental Portugese, possbily with some I<very>
+closely related languages like Czech and Slovak, and possibly with the
+slightly different "versions" of written Mandarin Chinese, as I hear exist in
+Taiwan and mainland China.)
+
+As to sharing of auxiliary functions, consider the problem of Russian
+numbers from the beginning of this article; obviously, you'd want to
+write only once the hairy code that, given a numeric value, would
+return some specification of which case and number a given quanitified
+noun should use. But suppose that you discover, while localizing an
+interface for, say, Ukranian (a Slavic language related to Russian,
+spoken by several million people, many of whom would be relieved to
+find that your Web site's or software's interface is available in
+their language), that the rules in Ukranian are the same as in Russian
+for quantification, and probably for many other grammatical functions.
+While there may well be no phrases in common between Russian and
+Ukranian, you could still choose to have the Ukranian module inherit
+from the Russian module, just for the sake of inheriting all the
+various grammatical methods. Or, probably better organizationally,
+you could move those functions to a module called C<_E_Slavic> or
+something, which Russian and Ukranian could inherit useful functions
+from, but which would (presumably) provide no lexicon.
+
+=head2 Buzzword: Concision
+
+Okay, concision isn't a buzzword. But it should be, so I decree that
+as a new buzzword, "concision" means that simple common things should
+be expressible in very few lines (or maybe even just a few characters)
+of code -- call it a special case of "making simple things easy and
+hard things possible", and see also the role it played in the
+MIDI::Simple language, discussed elsewhere in this issue [TPJ#13].
+
+Consider our first stab at an entry in our "phrasebook of functions":
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = sprintf("%g %s", $files,
+ $files == 1 ? 'fichier' : 'fichiers');
+ $dirs = sprintf("%g %s", $dirs,
+ $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+You may sense that a lexicon (to use a non-committal catch-all term for a
+collection of things you know how to say, regardless of whether they're
+phrases or words) consisting of functions I<expressed> as above would
+make for rather long-winded and repetitive code -- even if you wisely
+rewrote this to have quantification (as we call adding a number
+expression to a noun phrase) be a function called like:
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = quant($files, "fichier");
+ $dirs = quant($dirs, "r\xE9pertoire");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+And you may also sense that you do not want to bother your translators
+with having to write Perl code -- you'd much rather that they spend
+their I<very costly time> on just translation. And this is to say
+nothing of the near impossibility of finding a commercial translator
+who would know even simple Perl.
+
+In a first-hack implementation of Maketext, each language-module's
+lexicon looked like this:
+
+ %Lexicon = (
+ "I found %g files in %g directories"
+ => sub {
+ my( $files, $dirs ) = @_[0,1];
+ $files = quant($files, "fichier");
+ $dirs = quant($dirs, "r\xE9pertoire");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ },
+ ... and so on with other phrase => sub mappings ...
+ );
+
+but I immediately went looking for some more concise way to basically
+denote the same phrase-function -- a way that would also serve to
+concisely denote I<most> phrase-functions in the lexicon for I<most>
+languages. After much time and even some actual thought, I decided on
+this system:
+
+* Where a value in a %Lexicon hash is a contentful string instead of
+an anonymous sub (or, conceivably, a coderef), it would be interpreted
+as a sort of shorthand expression of what the sub does. When accessed
+for the first time in a session, it is parsed, turned into Perl code,
+and then eval'd into an anonymous sub; then that sub replaces the
+original string in that lexicon. (That way, the work of parsing and
+evaling the shorthand form for a given phrase is done no more than
+once per session.)
+
+* Calls to C<maketext> (as Maketext's main function is called) happen
+thru a "language session handle", notionally very much like an IO
+handle, in that you open one at the start of the session, and use it
+for "sending signals" to an object in order to have it return the text
+you want.
+
+So, this:
+
+ $lang->maketext("You have [quant,_1,piece] of new mail.",
+ scalar(@messages));
+
+basically means this: look in the lexicon for $lang (which may inherit
+from any number of other lexicons), and find the function that we
+happen to associate with the string "You have [quant,_1,piece] of new
+mail" (which is, and should be, a functioning "shorthand" for this
+function in the native locale -- English in this case). If you find
+such a function, call it with $lang as its first parameter (as if it
+were a method), and then a copy of scalar(@messages) as its second,
+and then return that value. If that function was found, but was in
+string shorthand instead of being a fully specified function, parse it
+and make it into a function before calling it the first time.
+
+* The shorthand uses code in brackets to indicate method calls that
+should be performed. A full explanation is not in order here, but a
+few examples will suffice:
+
+ "You have [quant,_1,piece] of new mail."
+
+The above code is shorthand for, and will be interpreted as,
+this:
+
+ sub {
+ my $handle = $_[0];
+ my(@params) = @_;
+ return join '',
+ "You have ",
+ $handle->quant($params[1], 'piece'),
+ "of new mail.";
+ }
+
+where "quant" is the name of a method you're using to quantify the
+noun "piece" with the number $params[0].
+
+A string with no brackety calls, like this:
+
+ "Your search expression was malformed."
+
+is somewhat of a degerate case, and just gets turned into:
+
+ sub { return "Your search expression was malformed." }
+
+However, not everything you can write in Perl code can be written in
+the above shorthand system -- not by a long shot. For example, consider
+the Italian translator from the beginning of this article, who wanted
+the Italian for "I didn't find any files" as a special case, instead
+of "I found 0 files". That couldn't be specified (at least not easily
+or simply) in our shorthand system, and it would have to be written
+out in full, like this:
+
+ sub { # pretend the English strings are in Italian
+ my($handle, $files, $dirs) = @_[0,1,2];
+ return "I didn't find any files" unless $files;
+ return join '',
+ "I found ",
+ $handle->quant($files, 'file'),
+ " in ",
+ $handle->quant($dirs, 'directory'),
+ ".";
+ }
+
+Next to a lexicon full of shorthand code, that sort of sticks out like a
+sore thumb -- but this I<is> a special case, after all; and at least
+it's possible, if not as concise as usual.
+
+As to how you'd implement the Russian example from the beginning of
+the article, well, There's More Than One Way To Do It, but it could be
+something like this (using English words for Russian, just so you know
+what's going on):
+
+ "I [quant,_1,directory,accusative] scanned."
+
+This shifts the burden of complexity off to the quant method. That
+method's parameters are: the numeric value it's going to use to
+quantify something; the Russian word it's going to quantify; and the
+parameter "accusative", which you're using to mean that this
+sentence's syntax wants a noun in the accusative case there, although
+that quantification method may have to overrule, for grammatical
+reasons you may recall from the beginning of this article.
+
+Now, the Russian quant method here is responsible not only for
+implementing the strange logic necessary for figuring out how Russian
+number-phrases impose case and number on their noun-phrases, but also
+for inflecting the Russian word for "directory". How that inflection
+is to be carried out is no small issue, and among the solutions I've
+seen, some (like variations on a simple lookup in a hash where all
+possible forms are provided for all necessary words) are
+straightforward but I<can> become cumbersome when you need to inflect
+more than a few dozen words; and other solutions (like using
+algorithms to model the inflections, storing only root forms and
+irregularities) I<can> involve more overhead than is justifiable for
+all but the largest lexicons.
+
+Mercifully, this design decision becomes crucial only in the hairiest
+of inflected languages, of which Russian is by no means the I<worst> case
+scenario, but is worse than most. Most languages have simpler
+inflection systems; for example, in English or Swahili, there are
+generally no more than two possible inflected forms for a given noun
+("error/errors"; "kosa/makosa"), and the
+rules for producing these forms are fairly simple -- or at least,
+simple rules can be formulated that work for most words, and you can
+then treat the exceptions as just "irregular", at least relative to
+your ad hoc rules. A simpler inflection system (simpler rules, fewer
+forms) means that design decisions are less crucial to maintaining
+sanity, whereas the same decisions could incur
+overhead-versus-scalability problems in languages like Russian. It
+may I<also> be likely that code (possibly in Perl, as with
+Lingua::EN::Inflect, for English nouns) has already
+been written for the language in question, whether simple or complex.
+
+Moreover, a third possibility may even be simpler than anything
+discussed above: "Just require that all possible (or at least
+applicable) forms be provided in the call to the given language's quant
+method, as in:"
+
+ "I found [quant,_1,file,files]."
+
+That way, quant just has to chose which form it needs, without having
+to look up or generate anything. While possibly not optimal for
+Russian, this should work well for most other languages, where
+quantification is not as complicated an operation.
+
+=head2 The Devil in the Details
+
+There's plenty more to Maketext than described above -- for example,
+there's the details of how language tags ("en-US", "i-pwn", "fi",
+etc.) or locale IDs ("en_US") interact with actual module naming
+("BogoQuery/Locale/en_us.pm"), and what magic can ensue; there's the
+details of how to record (and possibly negotiate) what character
+encoding Maketext will return text in (UTF8? Latin-1? KOI8?). There's
+the interesting fact that Maketext is for localization, but nowhere
+actually has a "C<use locale;>" anywhere in it. For the curious,
+there's the somewhat frightening details of how I actually
+implement something like data inheritance so that searches across
+modules' %Lexicon hashes can parallel how Perl implements method
+inheritance.
+
+And, most importantly, there's all the practical details of how to
+actually go about deriving from Maketext so you can use it for your
+interfaces, and the various tools and conventions for starting out and
+maintaining individual language modules.
+
+That is all covered in the documentation for Locale::Maketext and the
+modules that come with it, available in CPAN. After having read this
+article, which covers the why's of Maketext, the documentation,
+which covers the how's of it, should be quite straightfoward.
+
+=head2 The Proof in the Pudding: Localizing Web Sites
+
+Maketext and gettext have a notable difference: gettext is in C,
+accessible thru C library calls, whereas Maketext is in Perl, and
+really can't work without a Perl interpreter (although I suppose
+something like it could be written for C). Accidents of history (and
+not necessarily lucky ones) have made C++ the most common language for
+the implementation of applications like word processors, Web browsers,
+and even many in-house applications like custom query systems. Current
+conditions make it somewhat unlikely that the next one of any of these
+kinds of applications will be written in Perl, albeit clearly more for
+reasons of custom and inertia than out of consideration of what is the
+right tool for the job.
+
+However, other accidents of history have made Perl a well-accepted
+language for design of server-side programs (generally in CGI form)
+for Web site interfaces. Localization of static pages in Web sites is
+trivial, feasable either with simple language-negotiation features in
+servers like Apache, or with some kind of server-side inclusions of
+language-appropriate text into layout templates. However, I think
+that the localization of Perl-based search systems (or other kinds of
+dynamic content) in Web sites, be they public or access-restricted,
+is where Maketext will see the greatest use.
+
+I presume that it would be only the exceptional Web site that gets
+localized for English I<and> Chinese I<and> Italian I<and> Arabic
+I<and> Russian, to recall the languages from the beginning of this
+article -- to say nothing of German, Spanish, French, Japanese,
+Finnish, and Hindi, to name a few languages that benefit from large
+numbers of programmers or Web viewers or both.
+
+However, the ever-increasing internationalization of the Web (whether
+measured in terms of amount of content, of numbers of content writers
+or programmers, or of size of content audiences) makes it increasingly
+likely that the interface to the average Web-based dynamic content
+service will be localized for two or maybe three languages. It is my
+hope that Maketext will make that task as simple as possible, and will
+remove previous barriers to localization for languages dissimilar to
+English.
+
+ __END__
+
+Sean M. Burke (sburkeE<64>cpan.org) has a Master's in linguistics
+from Northwestern University; he specializes in language technology.
+Jordan Lachler (lachlerE<64>unm.edu) is a PhD student in the Department of
+Linguistics at the University of New Mexico; he specializes in
+morphology and pedagogy of North American native languages.
+
+=head2 References
+
+Alvestrand, Harald Tveit. 1995. I<RFC 1766: Tags for the
+Identification of Languages.>
+C<ftp://ftp.isi.edu/in-notes/rfc1766.txt>
+[Now see RFC 3066.]
+
+Callon, Ross, editor. 1996. I<RFC 1925: The Twelve
+Networking Truths.>
+C<ftp://ftp.isi.edu/in-notes/rfc1925.txt>
+
+Drepper, Ulrich, Peter Miller,
+and FranE<ccedil>ois Pinard. 1995-2001. GNU
+C<gettext>. Available in C<ftp://prep.ai.mit.edu/pub/gnu/>, with
+extensive docs in the distribution tarball. [Since
+I wrote this article in 1998, I now see that the
+gettext docs are now trying more to come to terms with
+plurality. Whether useful conclusions have come from it
+is another question altogether. -- SMB, May 2001]
+
+Forbes, Nevill. 1964. I<Russian Grammar.> Third Edition, revised
+by J. C. Dumbreck. Oxford University Press.
+
+=cut
+
+#End
+
diff --git a/Master/tlpkg/tlperl/lib/Locale/Script.pm b/Master/tlpkg/tlperl/lib/Locale/Script.pm
new file mode 100644
index 00000000000..f5fdbab05c9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Script.pm
@@ -0,0 +1,294 @@
+#
+# Locale::Script - ISO codes for script identification (ISO 15924)
+#
+# $Id: Script.pm,v 2.7 2004/06/10 21:19:34 neilb Exp $
+#
+
+package Locale::Script;
+use strict;
+require 5.002;
+
+require Exporter;
+use Carp;
+use Locale::Constants;
+
+
+#-----------------------------------------------------------------------
+# Public Global Variables
+#-----------------------------------------------------------------------
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+@ISA = qw(Exporter);
+@EXPORT = qw(code2script script2code
+ all_script_codes all_script_names
+ script_code2code
+ LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 LOCALE_CODE_NUMERIC);
+
+#-----------------------------------------------------------------------
+# Private Global Variables
+#-----------------------------------------------------------------------
+my $CODES = [];
+my $COUNTRIES = [];
+
+
+#=======================================================================
+#
+# code2script ( CODE [, CODESET ] )
+#
+#=======================================================================
+sub code2script
+{
+ my $code = shift;
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+
+ return undef unless defined $code;
+
+ #-------------------------------------------------------------------
+ # Make sure the code is in the right form before we use it
+ # to look up the corresponding script.
+ # We have to sprintf because the codes are given as 3-digits,
+ # with leading 0's. Eg 070 for Egyptian demotic.
+ #-------------------------------------------------------------------
+ if ($codeset == LOCALE_CODE_NUMERIC)
+ {
+ return undef if ($code =~ /\D/);
+ $code = sprintf("%.3d", $code);
+ }
+ else
+ {
+ $code = lc($code);
+ }
+
+ if (exists $CODES->[$codeset]->{$code})
+ {
+ return $CODES->[$codeset]->{$code};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such script code!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# script2code ( SCRIPT [, CODESET ] )
+#
+#=======================================================================
+sub script2code
+{
+ my $script = shift;
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+
+ return undef unless defined $script;
+ $script = lc($script);
+ if (exists $COUNTRIES->[$codeset]->{$script})
+ {
+ return $COUNTRIES->[$codeset]->{$script};
+ }
+ else
+ {
+ #---------------------------------------------------------------
+ # no such script!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+
+#=======================================================================
+#
+# script_code2code ( CODE, IN-CODESET, OUT-CODESET )
+#
+#=======================================================================
+sub script_code2code
+{
+ (@_ == 3) or croak "script_code2code() takes 3 arguments!";
+
+ my $code = shift;
+ my $inset = shift;
+ my $outset = shift;
+ my $outcode;
+ my $script;
+
+
+ return undef if $inset == $outset;
+ $script = code2script($code, $inset);
+ return undef if not defined $script;
+ $outcode = script2code($script, $outset);
+ return $outcode;
+}
+
+
+#=======================================================================
+#
+# all_script_codes()
+#
+#=======================================================================
+sub all_script_codes
+{
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+ return keys %{ $CODES->[$codeset] };
+}
+
+
+#=======================================================================
+#
+# all_script_names()
+#
+#=======================================================================
+sub all_script_names
+{
+ my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+ return values %{ $CODES->[$codeset] };
+}
+
+
+#=======================================================================
+#
+# initialisation code - stuff the DATA into the ALPHA2 hash
+#
+#=======================================================================
+{
+ my ($alpha2, $alpha3, $numeric);
+ my $script;
+ local $_;
+
+
+ while (<DATA>)
+ {
+ next unless /\S/;
+ chop;
+ ($alpha2, $alpha3, $numeric, $script) = split(/:/, $_, 4);
+
+ $CODES->[LOCALE_CODE_ALPHA_2]->{$alpha2} = $script;
+ $COUNTRIES->[LOCALE_CODE_ALPHA_2]->{"\L$script"} = $alpha2;
+
+ if ($alpha3)
+ {
+ $CODES->[LOCALE_CODE_ALPHA_3]->{$alpha3} = $script;
+ $COUNTRIES->[LOCALE_CODE_ALPHA_3]->{"\L$script"} = $alpha3;
+ }
+
+ if ($numeric)
+ {
+ $CODES->[LOCALE_CODE_NUMERIC]->{$numeric} = $script;
+ $COUNTRIES->[LOCALE_CODE_NUMERIC]->{"\L$script"} = $numeric;
+ }
+
+ }
+
+ close(DATA);
+}
+
+1;
+
+__DATA__
+am:ama:130:Aramaic
+ar:ara:160:Arabic
+av:ave:151:Avestan
+bh:bhm:300:Brahmi (Ashoka)
+bi:bid:372:Buhid
+bn:ben:325:Bengali
+bo:bod:330:Tibetan
+bp:bpm:285:Bopomofo
+br:brl:570:Braille
+bt:btk:365:Batak
+bu:bug:367:Buginese (Makassar)
+by:bys:550:Blissymbols
+ca:cam:358:Cham
+ch:chu:221:Old Church Slavonic
+ci:cir:291:Cirth
+cm:cmn:402:Cypro-Minoan
+co:cop:205:Coptic
+cp:cpr:403:Cypriote syllabary
+cy:cyr:220:Cyrillic
+ds:dsr:250:Deserel (Mormon)
+dv:dvn:315:Devanagari (Nagari)
+ed:egd:070:Egyptian demotic
+eg:egy:050:Egyptian hieroglyphs
+eh:egh:060:Egyptian hieratic
+el:ell:200:Greek
+eo:eos:210:Etruscan and Oscan
+et:eth:430:Ethiopic
+gl:glg:225:Glagolitic
+gm:gmu:310:Gurmukhi
+gt:gth:206:Gothic
+gu:guj:320:Gujarati
+ha:han:500:Han ideographs
+he:heb:125:Hebrew
+hg:hgl:420:Hangul
+hm:hmo:450:Pahawh Hmong
+ho:hoo:371:Hanunoo
+hr:hrg:410:Hiragana
+hu:hun:176:Old Hungarian runic
+hv:hvn:175:Kok Turki runic
+hy:hye:230:Armenian
+iv:ivl:610:Indus Valley
+ja:jap:930:(alias for Han + Hiragana + Katakana)
+jl:jlg:445:Cherokee syllabary
+jw:jwi:360:Javanese
+ka:kam:241:Georgian (Mxedruli)
+kh:khn:931:(alias for Hangul + Han)
+kk:kkn:411:Katakana
+km:khm:354:Khmer
+kn:kan:345:Kannada
+kr:krn:357:Karenni (Kayah Li)
+ks:kst:305:Kharoshthi
+kx:kax:240:Georgian (Xucuri)
+la:lat:217:Latin
+lf:laf:215:Latin (Fraktur variant)
+lg:lag:216:Latin (Gaelic variant)
+lo:lao:356:Lao
+lp:lpc:335:Lepcha (Rong)
+md:mda:140:Mandaean
+me:mer:100:Meroitic
+mh:may:090:Mayan hieroglyphs
+ml:mlm:347:Malayalam
+mn:mon:145:Mongolian
+my:mya:350:Burmese
+na:naa:400:Linear A
+nb:nbb:401:Linear B
+og:ogm:212:Ogham
+or:ory:327:Oriya
+os:osm:260:Osmanya
+ph:phx:115:Phoenician
+ph:pah:150:Pahlavi
+pl:pld:282:Pollard Phonetic
+pq:pqd:295:Klingon plQaD
+pr:prm:227:Old Permic
+ps:pst:600:Phaistos Disk
+rn:rnr:211:Runic (Germanic)
+rr:rro:620:Rongo-rongo
+sa:sar:110:South Arabian
+si:sin:348:Sinhala
+sj:syj:137:Syriac (Jacobite variant)
+sl:slb:440:Unified Canadian Aboriginal Syllabics
+sn:syn:136:Syriac (Nestorian variant)
+sw:sww:281:Shavian (Shaw)
+sy:syr:135:Syriac (Estrangelo)
+ta:tam:346:Tamil
+tb:tbw:373:Tagbanwa
+te:tel:340:Telugu
+tf:tfn:120:Tifnagh
+tg:tag:370:Tagalog
+th:tha:352:Thai
+tn:tna:170:Thaana
+tw:twr:290:Tengwar
+va:vai:470:Vai
+vs:vsp:280:Visible Speech
+xa:xas:000:Cuneiform, Sumero-Akkadian
+xf:xfa:105:Cuneiform, Old Persian
+xk:xkn:412:(alias for Hiragana + Katakana)
+xu:xug:106:Cuneiform, Ugaritic
+yi:yii:460:Yi
+zx:zxx:997:Unwritten language
+zy:zyy:998:Undetermined script
+zz:zzz:999:Uncoded script
diff --git a/Master/tlpkg/tlperl/lib/Locale/Script.pod b/Master/tlpkg/tlperl/lib/Locale/Script.pod
new file mode 100644
index 00000000000..93ff88245ea
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Script.pod
@@ -0,0 +1,253 @@
+
+=head1 NAME
+
+Locale::Script - ISO codes for script identification (ISO 15924)
+
+=head1 SYNOPSIS
+
+ use Locale::Script;
+ use Locale::Constants;
+
+ $script = code2script('ph'); # 'Phoenician'
+ $code = script2code('Tibetan'); # 'bo'
+ $code3 = script2code('Tibetan',
+ LOCALE_CODE_ALPHA_3); # 'bod'
+ $codeN = script2code('Tibetan',
+ LOCALE_CODE_ALPHA_NUMERIC); # 330
+
+ @codes = all_script_codes();
+ @scripts = all_script_names();
+
+
+=head1 DESCRIPTION
+
+The C<Locale::Script> module provides access to the ISO
+codes for identifying scripts, as defined in ISO 15924.
+For example, Egyptian hieroglyphs are denoted by the two-letter
+code 'eg', the three-letter code 'egy', and the numeric code 050.
+
+You can either access the codes via the conversion routines
+(described below), or with the two functions which return lists
+of all script codes or all script names.
+
+There are three different code sets you can use for identifying
+scripts:
+
+=over 4
+
+=item B<alpha-2>
+
+Two letter codes, such as 'bo' for Tibetan.
+This code set is identified with the symbol C<LOCALE_CODE_ALPHA_2>.
+
+=item B<alpha-3>
+
+Three letter codes, such as 'ell' for Greek.
+This code set is identified with the symbol C<LOCALE_CODE_ALPHA_3>.
+
+=item B<numeric>
+
+Numeric codes, such as 410 for Hiragana.
+This code set is identified with the symbol C<LOCALE_CODE_NUMERIC>.
+
+=back
+
+All of the routines take an optional additional argument
+which specifies the code set to use.
+If not specified, it defaults to the two-letter codes.
+This is partly for backwards compatibility (previous versions
+of Locale modules only supported the alpha-2 codes), and
+partly because they are the most widely used codes.
+
+The alpha-2 and alpha-3 codes are not case-dependent,
+so you can use 'BO', 'Bo', 'bO' or 'bo' for Tibetan.
+When a code is returned by one of the functions in
+this module, it will always be lower-case.
+
+=head2 SPECIAL CODES
+
+The standard defines various special codes.
+
+=over 4
+
+=item *
+
+The standard reserves codes in the ranges B<qa> - B<qt>,
+B<qaa> - B<qat>, and B<900> - B<919>, for private use.
+
+=item *
+
+B<zx>, B<zxx>, and B<997>, are the codes for unwritten languages.
+
+=item *
+
+B<zy>, B<zyy>, and B<998>, are the codes for an undetermined script.
+
+=item *
+
+B<zz>, B<zzz>, and B<999>, are the codes for an uncoded script.
+
+=back
+
+The private codes are not recognised by Locale::Script,
+but the others are.
+
+
+=head1 CONVERSION ROUTINES
+
+There are three conversion routines: C<code2script()>, C<script2code()>,
+and C<script_code2code()>.
+
+=over 4
+
+=item code2script( CODE, [ CODESET ] )
+
+This function takes a script code and returns a string
+which contains the name of the script identified.
+If the code is not a valid script code, as defined by ISO 15924,
+then C<undef> will be returned:
+
+ $script = code2script('cy'); # Cyrillic
+
+=item script2code( STRING, [ CODESET ] )
+
+This function takes a script name and returns the corresponding
+script code, if such exists.
+If the argument could not be identified as a script name,
+then C<undef> will be returned:
+
+ $code = script2code('Gothic', LOCALE_CODE_ALPHA_3);
+ # $code will now be 'gth'
+
+The case of the script name is not important.
+See the section L<KNOWN BUGS AND LIMITATIONS> below.
+
+=item script_code2code( CODE, CODESET, CODESET )
+
+This function takes a script code from one code set,
+and returns the corresponding code from another code set.
+
+ $alpha2 = script_code2code('jwi',
+ LOCALE_CODE_ALPHA_3 => LOCALE_CODE_ALPHA_2);
+ # $alpha2 will now be 'jw' (Javanese)
+
+If the code passed is not a valid script code in
+the first code set, or if there isn't a code for the
+corresponding script in the second code set,
+then C<undef> will be returned.
+
+=back
+
+
+=head1 QUERY ROUTINES
+
+There are two function which can be used to obtain a list of all codes,
+or all script names:
+
+=over 4
+
+=item C<all_script_codes ( [ CODESET ] )>
+
+Returns a list of all two-letter script codes.
+The codes are guaranteed to be all lower-case,
+and not in any particular order.
+
+=item C<all_script_names ( [ CODESET ] )>
+
+Returns a list of all script names for which there is a corresponding
+script code in the specified code set.
+The names are capitalised, and not returned in any particular order.
+
+=back
+
+
+=head1 EXAMPLES
+
+The following example illustrates use of the C<code2script()> function.
+The user is prompted for a script code, and then told the corresponding
+script name:
+
+ $| = 1; # turn off buffering
+
+ print "Enter script code: ";
+ chop($code = <STDIN>);
+ $script = code2script($code, LOCALE_CODE_ALPHA_2);
+ if (defined $script)
+ {
+ print "$code = $script\n";
+ }
+ else
+ {
+ print "'$code' is not a valid script code!\n";
+ }
+
+
+=head1 KNOWN BUGS AND LIMITATIONS
+
+=over 4
+
+=item *
+
+When using C<script2code()>, the script name must currently appear
+exactly as it does in the source of the module. For example,
+
+ script2code('Egyptian hieroglyphs')
+
+will return B<eg>, as expected. But the following will all return C<undef>:
+
+ script2code('hieroglyphs')
+ script2code('Egyptian Hieroglypics')
+
+If there's need for it, a future version could have variants
+for script names.
+
+=item *
+
+In the current implementation, all data is read in when the
+module is loaded, and then held in memory.
+A lazy implementation would be more memory friendly.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item Locale::Language
+
+ISO two letter codes for identification of language (ISO 639).
+
+=item Locale::Currency
+
+ISO three letter codes for identification of currencies
+and funds (ISO 4217).
+
+=item Locale::Country
+
+ISO three letter codes for identification of countries (ISO 3166)
+
+=item ISO 15924
+
+The ISO standard which defines these codes.
+
+=item http://www.evertype.com/standards/iso15924/
+
+Home page for ISO 15924.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Neil Bowers E<lt>neil@bowers.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2004 Neil Bowers.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Log/Message.pm b/Master/tlpkg/tlperl/lib/Log/Message.pm
new file mode 100644
index 00000000000..3b2f43e57da
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Log/Message.pm
@@ -0,0 +1,600 @@
+package Log::Message;
+
+use strict;
+
+use Params::Check qw[check];
+use Log::Message::Item;
+use Log::Message::Config;
+use Locale::Maketext::Simple Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+BEGIN {
+ use vars qw[$VERSION @ISA $STACK $CONFIG];
+
+ $VERSION = 0.02;
+
+ $STACK = [];
+}
+
+
+=pod
+
+=head1 NAME
+
+Log::Message - A generic message storing mechanism;
+
+=head1 SYNOPSIS
+
+ use Log::Message private => 0, config => '/our/cf_file';
+
+ my $log = Log::Message->new( private => 1,
+ level => 'log',
+ config => '/my/cf_file',
+ );
+
+ $log->store('this is my first message');
+
+ $log->store( message => 'message #2',
+ tag => 'MY_TAG',
+ level => 'carp',
+ extra => ['this is an argument to the handler'],
+ );
+
+ my @last_five_items = $log->retrieve(5);
+
+ my @items = $log->retrieve( tag => qr/my_tag/i,
+ message => qr/\d/,
+ remove => 1,
+ );
+
+ my @items = $log->final( level => qr/carp/, amount => 2 );
+
+ my $first_error = $log->first()
+
+ # croak with the last error on the stack
+ $log->final->croak;
+
+ # empty the stack
+ $log->flush();
+
+
+=head1 DESCRIPTION
+
+Log::Message is a generic message storage mechanism.
+It allows you to store messages on a stack -- either shared or private
+-- and assign meta-data to it.
+Some meta-data will automatically be added for you, like a timestamp
+and a stack trace, but some can be filled in by the user, like a tag
+by which to identify it or group it, and a level at which to handle
+the message (for example, log it, or die with it)
+
+Log::Message also provides a powerful way of searching through items
+by regexes on messages, tags and level.
+
+=head1 Hierarchy
+
+There are 4 modules of interest when dealing with the Log::Message::*
+modules:
+
+=over 4
+
+=item Log::Message
+
+Log::Message provides a few methods to manipulate the stack it keeps.
+It has the option of keeping either a private or a public stack.
+More on this below.
+
+=item Log::Message::Item
+
+These are individual message items, which are objects that contain
+the user message as well as the meta-data described above.
+See the L<Log::Message::Item> manpage to see how to extract this
+meta-data and how to work with the Item objects.
+You should never need to create your own Item objects, but knowing
+about their methods and accessors is important if you want to write
+your own handlers. (See below)
+
+=item Log::Message::Handlers
+
+These are a collection of handlers that will be called for a level
+that is used on a L<Log::Message::Item> object.
+For example, if a message is logged with the 'carp' level, the 'carp'
+handler from L<Log::Message::Handlers> will be called.
+See the L<Log::Message::Handlers> manpage for more explanation about how
+handlers work, which one are available and how to create your own.
+
+=item Log::Message::Config
+
+Per Log::Message object, there is a configuration required that will
+fill in defaults if the user did not specify arguments to override
+them (like for example what tag will be set if none was provided),
+L<Log::Message::Config> handles the creation of these configurations.
+
+Configuration can be specified in 4 ways:
+
+=over 4
+
+=item *
+
+As a configuration file when you C<use Log::Message>
+
+=item *
+
+As arguments when you C<use Log::Message>
+
+=item *
+
+As a configuration file when you create a new L<Log::Message> object.
+(The config will then only apply to that object if you marked it as
+private)
+
+=item *
+
+As arguments when you create a new Log::Message object.
+
+You should never need to use the L<Log::Message::Config> module yourself,
+as this is transparently done by L<Log::Message>, but its manpage does
+provide an explanation of how you can create a config file.
+
+=back
+
+=back
+
+=head1 Options
+
+When using Log::Message, or creating a new Log::Message object, you can
+supply various options to alter its behaviour.
+Of course, there are sensible defaults should you choose to omit these
+options.
+
+Below an explanation of all the options and how they work.
+
+=over 4
+
+=item config
+
+The path to a configuration file to be read.
+See the manpage of L<Log::Message::Config> for the required format
+
+These options will be overridden by any explicit arguments passed.
+
+=item private
+
+Whether to create, by default, private or shared objects.
+If you choose to create shared objects, all Log::Message objects will
+use the same stack.
+
+This means that even though every module may make its own $log object
+they will still be sharing the same error stack on which they are
+putting errors and from which they are retrieving.
+
+This can be useful in big projects.
+
+If you choose to create a private object, then the stack will of
+course be private to this object, but it will still fall back to the
+shared config should no private config or overriding arguments be
+provided.
+
+=item verbose
+
+Log::Message makes use of another module to validate its arguments,
+which is called L<Params::Check>, which is a lightweight, yet
+powerful input checker and parser. (See the L<Params::Check>
+manpage for details).
+
+The verbose setting will control whether this module will
+generate warnings if something improper is passed as input, or merely
+silently returns undef, at which point Log::Message will generate a
+warning.
+
+It's best to just leave this at its default value, which is '1'
+
+=item tag
+
+The tag to add to messages if none was provided. If neither your
+config, nor any specific arguments supply a tag, then Log::Message will
+set it to 'NONE'
+
+Tags are useful for searching on or grouping by. For example, you
+could tag all the messages you want to go to the user as 'USER ERROR'
+and all those that are only debug information with 'DEBUG'.
+
+At the end of your program, you could then print all the ones tagged
+'USER ERROR' to STDOUT, and those marked 'DEBUG' to a log file.
+
+=item level
+
+C<level> describes what action to take when a message is logged. Just
+like C<tag>, Log::Message will provide a default (which is 'log') if
+neither your config file, nor any explicit arguments are given to
+override it.
+
+See the Log::Message::Handlers manpage to see what handlers are
+available by default and what they do, as well as to how to add your
+own handlers.
+
+=item remove
+
+This indicates whether or not to automatically remove the messages
+from the stack when you've retrieved them.
+The default setting provided by Log::Message is '0': do not remove.
+
+=item chrono
+
+This indicates whether messages should always be fetched in
+chronological order or not.
+This simply means that you can choose whether, when retrieving items,
+the item most recently added should be returned first, or the one that
+had been added most long ago.
+
+The default is to return the newest ones first
+
+=back
+
+=cut
+
+
+### subs ###
+sub import {
+ my $pkg = shift;
+ my %hash = @_;
+
+ $CONFIG = new Log::Message::Config( %hash )
+ or die loc(qq[Problem initialising %1], __PACKAGE__);
+
+}
+
+=head1 Methods
+
+=head2 new
+
+This creates a new Log::Message object; The parameters it takes are
+described in the C<Options> section below and let it just be repeated
+that you can use these options like this:
+
+ my $log = Log::Message->new( %options );
+
+as well as during C<use> time, like this:
+
+ use Log::Message option1 => value, option2 => value
+
+There are but 3 rules to keep in mind:
+
+=over 4
+
+=item *
+
+Provided arguments take precedence over a configuration file.
+
+=item *
+
+Arguments to new take precedence over options provided at C<use> time
+
+=item *
+
+An object marked private will always have an empty stack to begin with
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $conf = new Log::Message::Config( %hash, default => $CONFIG ) or return undef;
+
+ if( $conf->private || $CONFIG->private ) {
+
+ return _new_stack( $class, config => $conf );
+
+ } else {
+ my $obj = _new_stack( $class, config => $conf, stack => $STACK );
+
+ ### if it was an empty stack, this was the first object
+ ### in that case, set the global stack to match it for
+ ### subsequent new, non-private objects
+ $STACK = $obj->{STACK} unless scalar @$STACK;
+
+ return $obj;
+ }
+}
+
+sub _new_stack {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ stack => { default => [] },
+ config => { default => bless( {}, 'Log::Message::Config'),
+ required => 1,
+ strict_type => 1
+ },
+ };
+
+ my $args = check( $tmpl, \%hash, $CONFIG->verbose ) or (
+ warn(loc(q[Could not create a new stack object: %1],
+ Params::Check->last_error)
+ ),
+ return
+ );
+
+
+ my %self = map { uc, $args->{$_} } keys %$args;
+
+ return bless \%self, $class;
+}
+
+sub _get_conf {
+ my $self = shift;
+ my $what = shift;
+
+ return defined $self->{CONFIG}->$what()
+ ? $self->{CONFIG}->$what()
+ : defined $CONFIG->$what()
+ ? $CONFIG->$what()
+ : undef; # should never get here
+}
+
+=head2 store
+
+This will create a new Item object and store it on the stack.
+
+Possible arguments you can give to it are:
+
+=over 4
+
+=item message
+
+This is the only argument that is required. If no other arguments
+are given, you may even leave off the C<message> key. The argument
+will then automatically be assumed to be the message.
+
+=item tag
+
+The tag to add to this message. If not provided, Log::Message will look
+in your configuration for one.
+
+=item level
+
+The level at which this message should be handled. If not provided,
+Log::Message will look in your configuration for one.
+
+=item extra
+
+This is an array ref with arguments passed to the handler for this
+message, when it is called from store();
+
+The handler will receive them as a normal list
+
+=back
+
+store() will return true upon success and undef upon failure, as well
+as issue a warning as to why it failed.
+
+=cut
+
+### should extra be stored in the item object perhaps for later retrieval?
+sub store {
+ my $self = shift;
+ my %hash = ();
+
+ my $tmpl = {
+ message => {
+ default => '',
+ strict_type => 1,
+ required => 1,
+ },
+ tag => { default => $self->_get_conf('tag') },
+ level => { default => $self->_get_conf('level'), },
+ extra => { default => [], strict_type => 1 },
+ };
+
+ ### single arg means just the message
+ ### otherwise, they are named
+ if( @_ == 1 ) {
+ $hash{message} = shift;
+ } else {
+ %hash = @_;
+ }
+
+ my $args = check( $tmpl, \%hash ) or (
+ warn( loc(q[Could not store error: %1], Params::Check->last_error) ),
+ return
+ );
+
+ my $extra = delete $args->{extra};
+ my $item = Log::Message::Item->new( %$args,
+ parent => $self,
+ id => scalar @{$self->{STACK}}
+ )
+ or ( warn( loc(q[Could not create new log item!]) ), return undef );
+
+ push @{$self->{STACK}}, $item;
+
+ { no strict 'refs';
+
+ my $sub = $args->{level};
+
+ $item->$sub( @$extra );
+ }
+
+ return 1;
+}
+
+=head2 retrieve
+
+This will retrieve all message items matching the criteria specified
+from the stack.
+
+Here are the criteria you can discriminate on:
+
+=over 4
+
+=item tag
+
+A regex to which the tag must adhere. For example C<qr/\w/>.
+
+=item level
+
+A regex to which the level must adhere.
+
+=item message
+
+A regex to which the message must adhere.
+
+=item amount
+
+Maximum amount of errors to return
+
+=item chrono
+
+Return in chronological order, or not?
+
+=item remove
+
+Remove items from the stack upon retrieval?
+
+=back
+
+In scalar context it will return the first item matching your criteria
+and in list context, it will return all of them.
+
+If an error occurs while retrieving, a warning will be issued and
+undef will be returned.
+
+=cut
+
+sub retrieve {
+ my $self = shift;
+ my %hash = ();
+
+ my $tmpl = {
+ tag => { default => qr/.*/ },
+ level => { default => qr/.*/ },
+ message => { default => qr/.*/ },
+ amount => { default => '' },
+ remove => { default => $self->_get_conf('remove') },
+ chrono => { default => $self->_get_conf('chrono') },
+ };
+
+ ### single arg means just the amount
+ ### otherwise, they are named
+ if( @_ == 1 ) {
+ $hash{amount} = shift;
+ } else {
+ %hash = @_;
+ }
+
+ my $args = check( $tmpl, \%hash ) or (
+ warn( loc(q[Could not parse input: %1], Params::Check->last_error) ),
+ return
+ );
+
+ my @list =
+ grep { $_->tag =~ /$args->{tag}/ ? 1 : 0 }
+ grep { $_->level =~ /$args->{level}/ ? 1 : 0 }
+ grep { $_->message =~ /$args->{message}/ ? 1 : 0 }
+ grep { defined }
+ $args->{chrono}
+ ? @{$self->{STACK}}
+ : reverse @{$self->{STACK}};
+
+ my $amount = $args->{amount} || scalar @list;
+
+ my @rv = map {
+ $args->{remove} ? $_->remove : $_
+ } scalar @list > $amount
+ ? splice(@list,0,$amount)
+ : @list;
+
+ return wantarray ? @rv : $rv[0];
+}
+
+=head2 first
+
+This is a shortcut for retrieving the first item(s) stored on the
+stack. It will default to only retrieving one if called with no
+arguments, and will always return results in chronological order.
+
+If you only supply one argument, it is assumed to be the amount you
+wish returned.
+
+Furthermore, it can take the same arguments as C<retrieve> can.
+
+=cut
+
+sub first {
+ my $self = shift;
+
+ my $amt = @_ == 1 ? shift : 1;
+ return $self->retrieve( amount => $amt, @_, chrono => 1 );
+}
+
+=head2 last
+
+This is a shortcut for retrieving the last item(s) stored on the
+stack. It will default to only retrieving one if called with no
+arguments, and will always return results in reverse chronological
+order.
+
+If you only supply one argument, it is assumed to be the amount you
+wish returned.
+
+Furthermore, it can take the same arguments as C<retrieve> can.
+
+=cut
+
+sub final {
+ my $self = shift;
+
+ my $amt = @_ == 1 ? shift : 1;
+ return $self->retrieve( amount => $amt, @_, chrono => 0 );
+}
+
+=head2 flush
+
+This removes all items from the stack and returns them to the caller
+
+=cut
+
+sub flush {
+ my $self = shift;
+
+ return splice @{$self->{STACK}};
+}
+
+=head1 SEE ALSO
+
+L<Log::Message::Item>, L<Log::Message::Handlers>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@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.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Log/Message/Config.pm b/Master/tlpkg/tlperl/lib/Log/Message/Config.pm
new file mode 100644
index 00000000000..9769119ed32
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Log/Message/Config.pm
@@ -0,0 +1,197 @@
+package Log::Message::Config;
+use strict;
+
+use Params::Check qw[check];
+use Module::Load;
+use FileHandle;
+use Locale::Maketext::Simple Style => 'gettext';
+
+BEGIN {
+ use vars qw[$VERSION $AUTOLOAD];
+ $VERSION = 0.01;
+}
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### find out if the user specified a config file to use
+ ### and/or a default configuration object
+ ### and remove them from the argument hash
+ my %special = map { lc, delete $hash{$_} }
+ grep /^config|default$/i, keys %hash;
+
+ ### allow provided arguments to override the values from the config ###
+ my $tmpl = {
+ private => { default => undef, },
+ verbose => { default => 1 },
+ tag => { default => 'NONE', },
+ level => { default => 'log', },
+ remove => { default => 0 },
+ chrono => { default => 1 },
+ };
+
+ my %lc_hash = map { lc, $hash{$_} } keys %hash;
+
+ my $file_conf;
+ if( $special{config} ) {
+ $file_conf = _read_config_file( $special{config} )
+ or ( warn( loc(q[Could not parse config file!]) ), return );
+ }
+
+ my $def_conf = \%{ $special{default} || {} };
+
+ ### make sure to only include keys that are actually defined --
+ ### the checker will assign even 'undef' if you have provided that
+ ### as a value
+ ### priorities goes as follows:
+ ### 1: arguments passed
+ ### 2: any config file passed
+ ### 3: any default config passed
+ my %to_check = map { @$_ }
+ grep { defined $_->[1] }
+ map { [ $_ =>
+ defined $lc_hash{$_} ? $lc_hash{$_} :
+ defined $file_conf->{$_} ? $file_conf->{$_} :
+ defined $def_conf->{$_} ? $def_conf->{$_} :
+ undef
+ ]
+ } keys %$tmpl;
+
+ my $rv = check( $tmpl, \%to_check, 1 )
+ or ( warn( loc(q[Could not validate arguments!]) ), return );
+
+ return bless $rv, $class;
+}
+
+sub _read_config_file {
+ my $file = shift or return;
+
+ my $conf = {};
+ my $FH = new FileHandle;
+ $FH->open("$file") or (
+ warn(loc(q[Could not open config file '%1': %2],$file,$!)),
+ return {}
+ );
+
+ while(<$FH>) {
+ next if /\s*#/;
+ next unless /\S/;
+
+ chomp; s/^\s*//; s/\s*$//;
+
+ my ($param,$val) = split /\s*=\s*/;
+
+ if( (lc $param) eq 'include' ) {
+ load $val;
+ next;
+ }
+
+ ### add these to the config hash ###
+ $conf->{ lc $param } = $val;
+ }
+ close $FH;
+
+ return $conf;
+}
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ s/.+:://;
+
+ my $self = shift;
+
+ return $self->{ lc $AUTOLOAD } if exists $self->{ lc $AUTOLOAD };
+
+ die loc(q[No such accessor '%1' for class '%2'], $AUTOLOAD, ref $self);
+}
+
+sub DESTROY { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Log::Message::Config - Configuration options for Log::Message
+
+=head1 SYNOPSIS
+
+ # This module is implicitly used by Log::Message to create a config
+ # which it uses to log messages.
+ # For the options you can pass, see the C<Log::Message new()> method.
+
+ # Below is a sample of a config file you could use
+
+ # comments are denoted by a single '#'
+ # use a shared stack, or have a private instance?
+ # if none provided, set to '0',
+ private = 1
+
+ # do not be verbose
+ verbose = 0
+
+ # default tag to set on new items
+ # if none provided, set to 'NONE'
+ tag = SOME TAG
+
+ # default level to handle items
+ # if none provided, set to 'log'
+ level = carp
+
+ # extra files to include
+ # if none provided, no files are auto included
+ include = mylib.pl
+ include = ../my/other/lib.pl
+
+ # automatically delete items
+ # when you retrieve them from the stack?
+ # if none provided, set to '0'
+ remove = 1
+
+ # retrieve errors in chronological order, or not?
+ # if none provided, set to '1'
+ chrono = 0
+
+=head1 DESCRIPTION
+
+Log::Message::Config provides a standardized config object for
+Log::Message objects.
+
+It can either read options as perl arguments, or as a config file.
+See the Log::Message manpage for more information about what arguments
+are valid, and see the Synopsis for an example config file you can use
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Item>, L<Log::Message::Handlers>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@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.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm b/Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm
new file mode 100644
index 00000000000..c7c35c6e389
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm
@@ -0,0 +1,191 @@
+package Log::Message::Handlers;
+use strict;
+
+=pod
+
+=head1 NAME
+
+Log::Message::Handlers - Message handlers for Log::Message
+
+=head1 SYNOPSIS
+
+ # Implicitly used by Log::Message to serve as handlers for
+ # Log::Message::Item objects
+
+ # Create your own file with a package called
+ # Log::Message::Handlers to add to the existing ones, or to even
+ # overwrite them
+
+ $item->carp;
+
+ $item->trace;
+
+
+=head1 DESCRIPTION
+
+Log::Message::Handlers provides handlers for Log::Message::Item objects.
+The handler corresponding to the level (see Log::Message::Item manpage
+for an explanation about levels) will be called automatically upon
+storing the error.
+
+Handlers may also explicitly be called on an Log::Message::Item object
+if one so desires (see the Log::Message manpage on how to retrieve the
+Item objects).
+
+=head1 Default Handlers
+
+=head2 log
+
+Will simply log the error on the stack, and do nothing special
+
+=cut
+
+sub log { 1 }
+
+=head2 carp
+
+Will carp (see the Carp manpage) with the error, and add the timestamp
+of when it occurred.
+
+=cut
+
+sub carp {
+ my $self = shift;
+ warn join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";
+}
+
+=head2 croak
+
+Will croak (see the Carp manpage) with the error, and add the
+timestamp of when it occurred.
+
+=cut
+
+sub croak {
+ my $self = shift;
+ die join " ", $self->message, $self->shortmess, 'at', $self->when, "\n";
+}
+
+=head2 cluck
+
+Will cluck (see the Carp manpage) with the error, and add the
+timestamp of when it occurred.
+
+=cut
+
+sub cluck {
+ my $self = shift;
+ warn join " ", $self->message, $self->longmess, 'at', $self->when, "\n";
+}
+
+=head2 confess
+
+Will confess (see the Carp manpage) with the error, and add the
+timestamp of when it occurred
+
+=cut
+
+sub confess {
+ my $self = shift;
+ die join " ", $self->message, $self->longmess, 'at', $self->when, "\n";
+}
+
+=head2 die
+
+Will simply die with the error message of the item
+
+=cut
+
+sub die { die shift->message; }
+
+
+=head2 warn
+
+Will simply warn with the error message of the item
+
+=cut
+
+sub warn { warn shift->message; }
+
+
+=head2 trace
+
+Will provide a traceback of this error item back to the first one that
+occurrent, clucking with every item as it comes across it.
+
+=cut
+
+sub trace {
+ my $self = shift;
+
+ for my $item( $self->parent->retrieve( chrono => 0 ) ) {
+ $item->cluck;
+ }
+}
+
+=head1 Custom Handlers
+
+If you wish to provide your own handlers, you can simply do the
+following:
+
+=over 4
+
+=item *
+
+Create a file that holds a package by the name of
+C<Log::Message::Handlers>
+
+=item *
+
+Create subroutines with the same name as the levels you wish to
+handle in the Log::Message module (see the Log::Message manpage for
+explanation on levels)
+
+=item *
+
+Require that file in your program, or add it in your configuration
+(see the Log::Message::Config manpage for explanation on how to use a
+config file)
+
+=back
+
+And that is it, the handler will now be available to handle messages
+for you.
+
+The arguments a handler may receive are those specified by the
+C<extra> key, when storing the message.
+See the Log::Message manpage for details on the arguments.
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Item>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@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.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Log/Message/Item.pm b/Master/tlpkg/tlperl/lib/Log/Message/Item.pm
new file mode 100644
index 00000000000..85ae6fc6003
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Log/Message/Item.pm
@@ -0,0 +1,192 @@
+package Log::Message::Item;
+
+use strict;
+use Params::Check qw[check];
+use Log::Message::Handlers;
+
+### for the messages to store ###
+use Carp ();
+
+BEGIN {
+ use vars qw[$AUTOLOAD $VERSION];
+
+ $VERSION = $Log::Message::VERSION;
+}
+
+### create a new item.
+### note that only an id (position on the stack), message and a reference
+### to its parent are required. all the other things it can fill in itself
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ when => { no_override => 1, default => scalar localtime },
+ id => { required => 1 },
+ message => { required => 1 },
+ parent => { required => 1 },
+ level => { default => '' }, # default may be conf dependant
+ tag => { default => '' }, # default may be conf dependant
+ longmess => { default => _clean(Carp::longmess()) },
+ shortmess => { default => _clean(Carp::shortmess())},
+ };
+
+ my $args = check($tmpl, \%hash) or return undef;
+
+ return bless $args, $class;
+}
+
+sub _clean { map { s/\s*//; chomp; $_ } shift; }
+
+sub remove {
+ my $item = shift;
+ my $self = $item->parent;
+
+ return splice( @{$self->{STACK}}, $item->id, 1, undef );
+}
+
+sub AUTOLOAD {
+ my $self = $_[0];
+
+ $AUTOLOAD =~ s/.+:://;
+
+ return $self->{$AUTOLOAD} if exists $self->{$AUTOLOAD};
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 3;
+
+ { no strict 'refs';
+ return *{"Log::Message::Handlers::${AUTOLOAD}"}->(@_);
+ }
+}
+
+sub DESTROY { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Log::Message::Item - Message objects for Log::Message
+
+=head1 SYNOPSIS
+
+ # Implicitly used by Log::Message to create Log::Message::Item objects
+
+ print "this is the message's id: ", $item->id;
+
+ print "this is the message stored: ", $item->message;
+
+ print "this is when it happened: ", $item->when;
+
+ print "the message was tagged: ", $item->tag;
+
+ print "this was the severity level: ", $item->level;
+
+ $item->remove; # delete the item from the stack it was on
+
+ # Besides these methods, you can also call the handlers on
+ # the object specificallly.
+ # See the Log::Message::Handlers manpage for documentation on what
+ # handlers are available by default and how to add your own
+
+
+=head1 DESCRIPTION
+
+Log::Message::Item is a class that generates generic Log items.
+These items are stored on a Log::Message stack, so see the Log::Message
+manpage about details how to retrieve them.
+
+You should probably not create new items by yourself, but use the
+storing mechanism provided by Log::Message.
+
+However, the accessors and handlers are of interest if you want to do
+fine tuning of how your messages are handled.
+
+The accessors and methods are described below, the handlers are
+documented in the Log::Message::Handlers manpage.
+
+=head1 Methods and Accessors
+
+=head2 remove
+
+Calling remove will remove the object from the stack it was on, so it
+will not show up any more in subsequent fetches of messages.
+
+You can still call accessors and handlers on it however, to handle it
+as you will.
+
+=head2 id
+
+Returns the internal ID of the item. This may be useful for comparing
+since the ID is incremented each time a new item is created.
+Therefore, an item with ID 4 must have been logged before an item with
+ID 9.
+
+=head2 when
+
+Returns the timestamp of when the message was logged
+
+=head2 message
+
+The actual message that was stored
+
+=head2 level
+
+The severity type of this message, as well as the name of the handler
+that was called upon storing it.
+
+=head2 tag
+
+Returns the identification tag that was put on the message.
+
+=head2 shortmess
+
+Returns the equivalent of a C<Carp::shortmess> for this item.
+See the C<Carp> manpage for details.
+
+=head2 longmess
+
+Returns the equivalent of a C<Carp::longmess> for this item, which
+is essentially a stack trace.
+See the C<Carp> manpage for details.
+
+=head2 parent
+
+Returns a reference to the Log::Message object that stored this item.
+This is useful if you want to have access to the full stack in a
+handler.
+
+=head1 SEE ALSO
+
+L<Log::Message>, L<Log::Message::Handlers>, L<Log::Message::Config>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Ann Barcomb for her suggestions.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2002 Jos Boumans E<lt>kane@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.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Log/Message/Simple.pm b/Master/tlpkg/tlperl/lib/Log/Message/Simple.pm
new file mode 100644
index 00000000000..18790365fdf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Log/Message/Simple.pm
@@ -0,0 +1,293 @@
+package Log::Message::Simple;
+
+use strict;
+use Log::Message private => 0;;
+
+BEGIN {
+ use vars qw[$VERSION];
+ $VERSION = 0.06;
+}
+
+
+=pod
+
+=head1 NAME
+
+Log::Message::Simple - Simplified interface to Log::Message
+
+=head1 SYNOPSIS
+
+ use Log::Message::Simple qw[msg error debug
+ carp croak cluck confess];
+
+ use Log::Message::Simple qw[:STD :CARP];
+
+ ### standard reporting functionality
+ msg( "Connecting to database", $verbose );
+ error( "Database connection failed: $@", $verbose );
+ debug( "Connection arguments were: $args", $debug );
+
+ ### standard carp functionality
+ carp( "Wrong arguments passed: @_" );
+ croak( "Fatal: wrong arguments passed: @_" );
+ cluck( "Wrong arguments passed -- including stacktrace: @_" );
+ confess("Fatal: wrong arguments passed -- including stacktrace: @_" );
+
+ ### retrieve individual message
+ my @stack = Log::Message::Simple->stack;
+ my @stack = Log::Message::Simple->flush;
+
+ ### retrieve the entire stack in printable form
+ my $msgs = Log::Message::Simple->stack_as_string;
+ my $trace = Log::Message::Simple->stack_as_string(1);
+
+ ### redirect output
+ local $Log::Message::Simple::MSG_FH = \*STDERR;
+ local $Log::Message::Simple::ERROR_FH = \*STDERR;
+ local $Log::Message::Simple::DEBUG_FH = \*STDERR;
+
+ ### force a stacktrace on error
+ local $Log::Message::Simple::STACKTRACE_ON_ERROR = 1
+
+=head1 DESCRIPTION
+
+This module provides standardized logging facilities using the
+C<Log::Message> module.
+
+=head1 FUNCTIONS
+
+=head2 msg("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT> (or actually
+C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 debug("message string" [,VERBOSE])
+
+Records a debug message on the stack, and prints it to C<STDOUT> (or
+actually C<$DEBUG_FH>, see the C<GLOBAL VARIABLES> section below),
+if the C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+Exported by default, or using the C<:STD> tag.
+
+=head2 error("error string" [,VERBOSE])
+
+Records an error on the stack, and prints it to C<STDERR> (or actually
+C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> options defaults to true.
+
+Exported by default, or using the C<:STD> tag.
+
+=cut
+
+{ package Log::Message::Handlers;
+
+ sub msg {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::MSG_FH;
+ print '['. $self->tag (). '] ' . $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+
+ sub debug {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::DEBUG_FH;
+ print '['. $self->tag (). '] ' . $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+
+ sub error {
+ my $self = shift;
+ my $verbose = shift;
+ $verbose = 1 unless defined $verbose; # default to true
+
+ ### so you don't want us to print the error? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $Log::Message::Simple::ERROR_FH;
+
+ my $msg = '['. $self->tag . '] ' . $self->message;
+
+ print $Log::Message::Simple::STACKTRACE_ON_ERROR
+ ? Carp::shortmess($msg)
+ : $msg . "\n";
+
+ select $old_fh;
+
+ return;
+ }
+}
+
+=head2 carp();
+
+Provides functionality equal to C<Carp::carp()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 croak();
+
+Provides functionality equal to C<Carp::croak()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 confess();
+
+Provides functionality equal to C<Carp::confess()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head2 cluck();
+
+Provides functionality equal to C<Carp::cluck()> while still logging
+to the stack.
+
+Exported by using the C<:CARP> tag.
+
+=head1 CLASS METHODS
+
+=head2 Log::Message::Simple->stack()
+
+Retrieves all the items on the stack. Since C<Log::Message::Simple> is
+implemented using C<Log::Message>, consult its manpage for the
+function C<retrieve> to see what is returned and how to use the items.
+
+=head2 Log::Message::Simple->stack_as_string([TRACE])
+
+Returns the whole stack as a printable string. If the C<TRACE> option is
+true all items are returned with C<Carp::longmess> output, rather than
+just the message.
+C<TRACE> defaults to false.
+
+=head2 Log::Message::Simple->flush()
+
+Removes all the items from the stack and returns them. Since
+C<Log::Message::Simple> is implemented using C<Log::Message>, consult its
+manpage for the function C<retrieve> to see what is returned and how
+to use the items.
+
+=cut
+
+BEGIN {
+ use Exporter;
+ use Params::Check qw[ check ];
+ use vars qw[ @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA ];;
+
+ @ISA = 'Exporter';
+ @EXPORT = qw[error msg debug];
+ @EXPORT_OK = qw[carp cluck croak confess];
+
+ %EXPORT_TAGS = (
+ STD => \@EXPORT,
+ CARP => \@EXPORT_OK,
+ ALL => [ @EXPORT, @EXPORT_OK ],
+ );
+
+ my $log = new Log::Message;
+
+ for my $func ( @EXPORT, @EXPORT_OK ) {
+ no strict 'refs';
+
+ ### up the carplevel for the carp emulation
+ ### functions
+ *$func = sub { local $Carp::CarpLevel += 2
+ if grep { $_ eq $func } @EXPORT_OK;
+
+ my $msg = shift;
+ $log->store(
+ message => $msg,
+ tag => uc $func,
+ level => $func,
+ extra => [@_]
+ );
+ };
+ }
+
+ sub flush {
+ return reverse $log->flush;
+ }
+
+ sub stack {
+ return $log->retrieve( chrono => 1 );
+ }
+
+ sub stack_as_string {
+ my $class = shift;
+ my $trace = shift() ? 1 : 0;
+
+ return join $/, map {
+ '[' . $_->tag . '] [' . $_->when . '] ' .
+ ($trace ? $_->message . ' ' . $_->longmess
+ : $_->message);
+ } __PACKAGE__->stack;
+ }
+}
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $ERROR_FH
+
+This is the filehandle all the messages sent to C<error()> are being
+printed. This defaults to C<*STDERR>.
+
+=item $MSG_FH
+
+This is the filehandle all the messages sent to C<msg()> are being
+printed. This default to C<*STDOUT>.
+
+=item $DEBUG_FH
+
+This is the filehandle all the messages sent to C<debug()> are being
+printed. This default to C<*STDOUT>.
+
+=item $STACKTRACE_ON_ERROR
+
+If this option is set to C<true>, every call to C<error()> will
+generate a stacktrace using C<Carp::shortmess()>.
+Defaults to C<false>
+
+=cut
+
+BEGIN {
+ use vars qw[ $ERROR_FH $MSG_FH $DEBUG_FH $STACKTRACE_ON_ERROR ];
+
+ local $| = 1;
+ $ERROR_FH = \*STDERR;
+ $MSG_FH = \*STDOUT;
+ $DEBUG_FH = \*STDOUT;
+
+ $STACKTRACE_ON_ERROR = 0;
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/MIME/Base64.pm b/Master/tlpkg/tlperl/lib/MIME/Base64.pm
new file mode 100644
index 00000000000..6c076d1b7c4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/MIME/Base64.pm
@@ -0,0 +1,175 @@
+package MIME::Base64;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(encode_base64 decode_base64);
+
+$VERSION = '3.08';
+
+require XSLoader;
+XSLoader::load('MIME::Base64', $VERSION);
+
+*encode = \&encode_base64;
+*decode = \&decode_base64;
+
+1;
+
+__END__
+
+=head1 NAME
+
+MIME::Base64 - Encoding and decoding of base64 strings
+
+=head1 SYNOPSIS
+
+ use MIME::Base64;
+
+ $encoded = encode_base64('Aladdin:open sesame');
+ $decoded = decode_base64($encoded);
+
+=head1 DESCRIPTION
+
+This module provides functions to encode and decode strings into and from the
+base64 encoding specified in RFC 2045 - I<MIME (Multipurpose Internet
+Mail Extensions)>. The base64 encoding is designed to represent
+arbitrary sequences of octets in a form that need not be humanly
+readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used,
+enabling 6 bits to be represented per printable character.
+
+The following functions are provided:
+
+=over 4
+
+=item encode_base64($str)
+
+=item encode_base64($str, $eol);
+
+Encode data by calling the encode_base64() function. The first
+argument is the string to encode. The second argument is the
+line-ending sequence to use. It is optional and defaults to "\n". The
+returned encoded string is broken into lines of no more than 76
+characters each and it will end with $eol unless it is empty. Pass an
+empty string as second argument if you do not want the encoded string
+to be broken into lines.
+
+=item decode_base64($str)
+
+Decode a base64 string by calling the decode_base64() function. This
+function takes a single argument which is the string to decode and
+returns the decoded data.
+
+Any character not part of the 65-character base64 subset is
+silently ignored. Characters occurring after a '=' padding character
+are never decoded.
+
+If the length of the string to decode, after ignoring
+non-base64 chars, is not a multiple of 4 or if padding occurs too early,
+then a warning is generated if perl is running under C<-w>.
+
+=back
+
+If you prefer not to import these routines into your namespace, you can
+call them as:
+
+ use MIME::Base64 ();
+ $encoded = MIME::Base64::encode($decoded);
+ $decoded = MIME::Base64::decode($encoded);
+
+=head1 DIAGNOSTICS
+
+The following warnings can be generated if perl is invoked with the
+C<-w> switch:
+
+=over 4
+
+=item Premature end of base64 data
+
+The number of characters to decode is not a multiple of 4. Legal
+base64 data should be padded with one or two "=" characters to make
+its length a multiple of 4. The decoded result will be the same
+whether the padding is present or not.
+
+=item Premature padding of base64 data
+
+The '=' padding character occurs as the first or second character
+in a base64 quartet.
+
+=back
+
+The following exception can be raised:
+
+=over 4
+
+=item Wide character in subroutine entry
+
+The string passed to encode_base64() contains characters with code
+above 255. The base64 encoding is only defined for single-byte
+characters. Use the Encode module to select the byte encoding you
+want.
+
+=back
+
+=head1 EXAMPLES
+
+If you want to encode a large file, you should encode it in chunks
+that are a multiple of 57 bytes. This ensures that the base64 lines
+line up and that you do not end up with padding in the middle. 57
+bytes of data fills one complete base64 line (76 == 57*4/3):
+
+ use MIME::Base64 qw(encode_base64);
+
+ open(FILE, "/var/log/wtmp") or die "$!";
+ while (read(FILE, $buf, 60*57)) {
+ print encode_base64($buf);
+ }
+
+or if you know you have enough memory
+
+ use MIME::Base64 qw(encode_base64);
+ local($/) = undef; # slurp
+ print encode_base64(<STDIN>);
+
+The same approach as a command line:
+
+ perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)' <file
+
+Decoding does not need slurp mode if every line contains a multiple
+of four base64 chars:
+
+ perl -MMIME::Base64 -ne 'print decode_base64($_)' <file
+
+Perl v5.8 and better allow extended Unicode characters in strings.
+Such strings cannot be encoded directly, as the base64
+encoding is only defined for single-byte characters. The solution is
+to use the Encode module to select the byte encoding you want. For
+example:
+
+ use MIME::Base64 qw(encode_base64);
+ use Encode qw(encode);
+
+ $encoded = encode_base64(encode("UTF-8", "\x{FFFF}\n"));
+ print $encoded;
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999, 2001-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Distantly based on LWP::Base64 written by Martijn Koster
+<m.koster@nexor.co.uk> and Joerg Reichelt <j.reichelt@nexor.co.uk> and
+code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans
+Mulder <hansm@wsinti07.win.tue.nl>
+
+The XS implementation uses code from metamail. Copyright 1991 Bell
+Communications Research, Inc. (Bellcore)
+
+=head1 SEE ALSO
+
+L<MIME::QuotedPrint>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm b/Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm
new file mode 100644
index 00000000000..aee13d6256b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm
@@ -0,0 +1,114 @@
+package MIME::QuotedPrint;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(encode_qp decode_qp);
+
+$VERSION = "3.08";
+
+use MIME::Base64; # will load XS version of {en,de}code_qp()
+
+*encode = \&encode_qp;
+*decode = \&decode_qp;
+
+1;
+
+__END__
+
+=head1 NAME
+
+MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
+
+=head1 SYNOPSIS
+
+ use MIME::QuotedPrint;
+
+ $encoded = encode_qp($decoded);
+ $decoded = decode_qp($encoded);
+
+=head1 DESCRIPTION
+
+This module provides functions to encode and decode strings into and from the
+quoted-printable encoding specified in RFC 2045 - I<MIME (Multipurpose
+Internet Mail Extensions)>. The quoted-printable encoding is intended
+to represent data that largely consists of bytes that correspond to
+printable characters in the ASCII character set. Each non-printable
+character (as defined by English Americans) is represented by a
+triplet consisting of the character "=" followed by two hexadecimal
+digits.
+
+The following functions are provided:
+
+=over 4
+
+=item encode_qp($str)
+
+=item encode_qp($str, $eol)
+
+=item encode_qp($str, $eol, $binmode)
+
+This function returns an encoded version of the string ($str) given as
+argument.
+
+The second argument ($eol) is the line-ending sequence to use. It is
+optional and defaults to "\n". Every occurrence of "\n" is replaced
+with this string, and it is also used for additional "soft line
+breaks" to ensure that no line end up longer than 76 characters. Pass
+it as "\015\012" to produce data suitable for external consumption.
+The string "\r\n" produces the same result on many platforms, but not
+all.
+
+The third argument ($binmode) will select binary mode if passed as a
+TRUE value. In binary mode "\n" will be encoded in the same way as
+any other non-printable character. This ensures that a decoder will
+end up with exactly the same string whatever line ending sequence it
+uses. In general it is preferable to use the base64 encoding for
+binary data; see L<MIME::Base64>.
+
+An $eol of "" (the empty string) is special. In this case, no "soft
+line breaks" are introduced and binary mode is effectively enabled so
+that any "\n" in the original data is encoded as well.
+
+=item decode_qp($str);
+
+This function returns the plain text version of the string given
+as argument. The lines of the result are "\n" terminated, even if
+the $str argument contains "\r\n" terminated lines.
+
+=back
+
+
+If you prefer not to import these routines into your namespace, you can
+call them as:
+
+ use MIME::QuotedPrint ();
+ $encoded = MIME::QuotedPrint::encode($decoded);
+ $decoded = MIME::QuotedPrint::decode($encoded);
+
+Perl v5.8 and better allow extended Unicode characters in strings.
+Such strings cannot be encoded directly, as the quoted-printable
+encoding is only defined for single-byte characters. The solution is
+to use the Encode module to select the byte encoding you want. For
+example:
+
+ use MIME::QuotedPrint qw(encode_qp);
+ use Encode qw(encode);
+
+ $encoded = encode_qp(encode("UTF-8", "\x{FFFF}\n"));
+ print $encoded;
+
+=head1 COPYRIGHT
+
+Copyright 1995-1997,2002-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MIME::Base64>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigFloat.pm b/Master/tlpkg/tlperl/lib/Math/BigFloat.pm
new file mode 100644
index 00000000000..27d60b3143c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigFloat.pm
@@ -0,0 +1,4402 @@
+package Math::BigFloat;
+
+#
+# Mike grinned. 'Two down, infinity to go' - Mike Nostrus in 'Before and After'
+#
+
+# The following hash values are internally used:
+# _e : exponent (ref to $CALC object)
+# _m : mantissa (ref to $CALC object)
+# _es : sign of _e
+# sign : +,-,+inf,-inf, or "NaN" if not a number
+# _a : accuracy
+# _p : precision
+
+$VERSION = '1.60';
+require 5.006;
+
+require Exporter;
+@ISA = qw/Math::BigInt/;
+@EXPORT_OK = qw/bpi/;
+
+use strict;
+# $_trap_inf/$_trap_nan are internal and should never be accessed from outside
+use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode
+ $upgrade $downgrade $_trap_nan $_trap_inf/;
+my $class = "Math::BigFloat";
+
+use overload
+'<=>' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ ref($_[0])->bcmp($_[0],$_[1]);
+ $rc = 1 unless defined $rc;
+ $rc <=> 0;
+ },
+# we need '>=' to get things like "1 >= NaN" right:
+'>=' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ ref($_[0])->bcmp($_[0],$_[1]);
+ # if there was a NaN involved, return false
+ return '' unless defined $rc;
+ $rc >= 0;
+ },
+'int' => sub { $_[0]->as_number() }, # 'trunc' to bigint
+;
+
+##############################################################################
+# global constants, flags and assorted stuff
+
+# the following are public, but their usage is not recommended. Use the
+# accessor methods instead.
+
+# class constants, use Class->constant_name() to access
+# one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+$round_mode = 'even';
+$accuracy = undef;
+$precision = undef;
+$div_scale = 40;
+
+$upgrade = undef;
+$downgrade = undef;
+# the package we are using for our private parts, defaults to:
+# Math::BigInt->config()->{lib}
+my $MBI = 'Math::BigInt::FastCalc';
+
+# are NaNs ok? (otherwise it dies when encountering an NaN) set w/ config()
+$_trap_nan = 0;
+# the same for infinity
+$_trap_inf = 0;
+
+# constant for easier life
+my $nan = 'NaN';
+
+my $IMPORT = 0; # was import() called yet? used to make require work
+
+# some digits of accuracy for blog(undef,10); which we use in blog() for speed
+my $LOG_10 =
+ '2.3025850929940456840179914546843642076011014886287729760333279009675726097';
+my $LOG_10_A = length($LOG_10)-1;
+# ditto for log(2)
+my $LOG_2 =
+ '0.6931471805599453094172321214581765680755001343602552541206800094933936220';
+my $LOG_2_A = length($LOG_2)-1;
+my $HALF = '0.5'; # made into an object if nec.
+
+##############################################################################
+# the old code had $rnd_mode, so we need to support it, too
+
+sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
+sub FETCH { return $round_mode; }
+sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
+
+BEGIN
+ {
+ # when someone sets $rnd_mode, we catch this and check the value to see
+ # whether it is valid or not.
+ $rnd_mode = 'even'; tie $rnd_mode, 'Math::BigFloat';
+
+ # we need both of them in this package:
+ *as_int = \&as_number;
+ }
+
+##############################################################################
+
+{
+ # valid method aliases for AUTOLOAD
+ my %methods = map { $_ => 1 }
+ qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm
+ fint facmp fcmp fzero fnan finf finc fdec ffac fneg
+ fceil ffloor frsft flsft fone flog froot fexp
+ /;
+ # valid methods that can be handed up (for AUTOLOAD)
+ my %hand_ups = map { $_ => 1 }
+ qw / is_nan is_inf is_negative is_positive is_pos is_neg
+ accuracy precision div_scale round_mode fabs fnot
+ objectify upgrade downgrade
+ bone binf bnan bzero
+ bsub
+ /;
+
+ sub _method_alias { exists $methods{$_[0]||''}; }
+ sub _method_hand_up { exists $hand_ups{$_[0]||''}; }
+}
+
+##############################################################################
+# constructors
+
+sub new
+ {
+ # create a new BigFloat object from a string or another bigfloat object.
+ # _e: exponent
+ # _m: mantissa
+ # sign => sign (+/-), or "NaN"
+
+ my ($class,$wanted,@r) = @_;
+
+ # avoid numify-calls by not using || on $wanted!
+ return $class->bzero() if !defined $wanted; # default to 0
+ return $wanted->copy() if UNIVERSAL::isa($wanted,'Math::BigFloat');
+
+ $class->import() if $IMPORT == 0; # make require work
+
+ my $self = {}; bless $self, $class;
+ # shortcut for bigints and its subclasses
+ if ((ref($wanted)) && UNIVERSAL::can( $wanted, "as_number"))
+ {
+ $self->{_m} = $wanted->as_number()->{value}; # get us a bigint copy
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{sign} = $wanted->sign();
+ return $self->bnorm();
+ }
+ # else: got a string or something maskerading as number (with overload)
+
+ # handle '+inf', '-inf' first
+ if ($wanted =~ /^[+-]?inf\z/)
+ {
+ return $downgrade->new($wanted) if $downgrade;
+
+ $self->{sign} = $wanted; # set a default sign for bstr()
+ return $self->binf($wanted);
+ }
+
+ # shortcut for simple forms like '12' that neither have trailing nor leading
+ # zeros
+ if ($wanted =~ /^([+-]?)([1-9][0-9]*[1-9])$/)
+ {
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{sign} = $1 || '+';
+ $self->{_m} = $MBI->_new($2);
+ return $self->round(@r) if !$downgrade;
+ }
+
+ my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($wanted);
+ if (!ref $mis)
+ {
+ if ($_trap_nan)
+ {
+ require Carp;
+ Carp::croak ("$wanted is not a number initialized to $class");
+ }
+
+ return $downgrade->bnan() if $downgrade;
+
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ $self->{_m} = $MBI->_zero();
+ $self->{sign} = $nan;
+ }
+ else
+ {
+ # make integer from mantissa by adjusting exp, then convert to int
+ $self->{_e} = $MBI->_new($$ev); # exponent
+ $self->{_es} = $$es || '+';
+ my $mantissa = "$$miv$$mfv"; # create mant.
+ $mantissa =~ s/^0+(\d)/$1/; # strip leading zeros
+ $self->{_m} = $MBI->_new($mantissa); # create mant.
+
+ # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5
+ if (CORE::length($$mfv) != 0)
+ {
+ my $len = $MBI->_new( CORE::length($$mfv));
+ ($self->{_e}, $self->{_es}) =
+ _e_sub ($self->{_e}, $len, $self->{_es}, '+');
+ }
+ # we can only have trailing zeros on the mantissa if $$mfv eq ''
+ else
+ {
+ # Use a regexp to count the trailing zeros in $$miv instead of _zeros()
+ # because that is faster, especially when _m is not stored in base 10.
+ my $zeros = 0; $zeros = CORE::length($1) if $$miv =~ /[1-9](0*)$/;
+ if ($zeros != 0)
+ {
+ my $z = $MBI->_new($zeros);
+ # turn '120e2' into '12e3'
+ $MBI->_rsft ( $self->{_m}, $z, 10);
+ ($self->{_e}, $self->{_es}) =
+ _e_add ( $self->{_e}, $z, $self->{_es}, '+');
+ }
+ }
+ $self->{sign} = $$mis;
+
+ # for something like 0Ey, set y to 1, and -0 => +0
+ # Check $$miv for being '0' and $$mfv eq '', because otherwise _m could not
+ # have become 0. That's faster than to call $MBI->_is_zero().
+ $self->{sign} = '+', $self->{_e} = $MBI->_one()
+ if $$miv eq '0' and $$mfv eq '';
+
+ return $self->round(@r) if !$downgrade;
+ }
+ # if downgrade, inf, NaN or integers go down
+
+ if ($downgrade && $self->{_es} eq '+')
+ {
+ if ($MBI->_is_zero( $self->{_e} ))
+ {
+ return $downgrade->new($$mis . $MBI->_str( $self->{_m} ));
+ }
+ return $downgrade->new($self->bsstr());
+ }
+ $self->bnorm()->round(@r); # first normalize, then round
+ }
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ if (@_ > 1)
+ {
+ my $self = bless {
+ sign => $_[1]->{sign},
+ _es => $_[1]->{_es},
+ _m => $MBI->_copy($_[1]->{_m}),
+ _e => $MBI->_copy($_[1]->{_e}),
+ }, $_[0] if @_ > 1;
+
+ $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
+ $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
+ return $self;
+ }
+
+ my $self = bless {
+ sign => $_[0]->{sign},
+ _es => $_[0]->{_es},
+ _m => $MBI->_copy($_[0]->{_m}),
+ _e => $MBI->_copy($_[0]->{_e}),
+ }, ref($_[0]);
+
+ $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
+ $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
+ $self;
+ }
+
+sub _bnan
+ {
+ # used by parent class bone() to initialize number to NaN
+ my $self = shift;
+
+ if ($_trap_nan)
+ {
+ require Carp;
+ my $class = ref($self);
+ Carp::croak ("Tried to set $self to NaN in $class\::_bnan()");
+ }
+
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _binf
+ {
+ # used by parent class bone() to initialize number to +-inf
+ my $self = shift;
+
+ if ($_trap_inf)
+ {
+ require Carp;
+ my $class = ref($self);
+ Carp::croak ("Tried to set $self to +-inf in $class\::_binf()");
+ }
+
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _bone
+ {
+ # used by parent class bone() to initialize number to 1
+ my $self = shift;
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_one();
+ $self->{_e} = $MBI->_zero();
+ $self->{_es} = '+';
+ }
+
+sub _bzero
+ {
+ # used by parent class bone() to initialize number to 0
+ my $self = shift;
+ $IMPORT=1; # call our import only once
+ $self->{_m} = $MBI->_zero();
+ $self->{_e} = $MBI->_one();
+ $self->{_es} = '+';
+ }
+
+sub isa
+ {
+ my ($self,$class) = @_;
+ return if $class =~ /^Math::BigInt/; # we aren't one of these
+ UNIVERSAL::isa($self,$class);
+ }
+
+sub config
+ {
+ # return (later set?) configuration data as hash ref
+ my $class = shift || 'Math::BigFloat';
+
+ if (@_ == 1 && ref($_[0]) ne 'HASH')
+ {
+ my $cfg = $class->SUPER::config();
+ return $cfg->{$_[0]};
+ }
+
+ my $cfg = $class->SUPER::config(@_);
+
+ # now we need only to override the ones that are different from our parent
+ $cfg->{class} = $class;
+ $cfg->{with} = $MBI;
+ $cfg;
+ }
+
+##############################################################################
+# string conversation
+
+sub bstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to (non-scientific) string format.
+ # internal format is always normalized (no leading zeros, "-0" => "+0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+
+ my $es = '0'; my $len = 1; my $cad = 0; my $dot = '.';
+
+ # $x is zero?
+ my $not_zero = !($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
+ if ($not_zero)
+ {
+ $es = $MBI->_str($x->{_m});
+ $len = CORE::length($es);
+ my $e = $MBI->_num($x->{_e});
+ $e = -$e if $x->{_es} eq '-';
+ if ($e < 0)
+ {
+ $dot = '';
+ # if _e is bigger than a scalar, the following will blow your memory
+ if ($e <= -$len)
+ {
+ my $r = abs($e) - $len;
+ $es = '0.'. ('0' x $r) . $es; $cad = -($len+$r);
+ }
+ else
+ {
+ substr($es,$e,0) = '.'; $cad = $MBI->_num($x->{_e});
+ $cad = -$cad if $x->{_es} eq '-';
+ }
+ }
+ elsif ($e > 0)
+ {
+ # expand with zeros
+ $es .= '0' x $e; $len += $e; $cad = 0;
+ }
+ } # if not zero
+
+ $es = '-'.$es if $x->{sign} eq '-';
+ # if set accuracy or precision, pad with zeros on the right side
+ if ((defined $x->{_a}) && ($not_zero))
+ {
+ # 123400 => 6, 0.1234 => 4, 0.001234 => 4
+ my $zeros = $x->{_a} - $cad; # cad == 0 => 12340
+ $zeros = $x->{_a} - $len if $cad != $len;
+ $es .= $dot.'0' x $zeros if $zeros > 0;
+ }
+ elsif ((($x->{_p} || 0) < 0))
+ {
+ # 123400 => 6, 0.1234 => 4, 0.001234 => 6
+ my $zeros = -$x->{_p} + $cad;
+ $es .= $dot.'0' x $zeros if $zeros > 0;
+ }
+ $es;
+ }
+
+sub bsstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to scientific string format.
+ # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my $sep = 'e'.$x->{_es};
+ my $sign = $x->{sign}; $sign = '' if $sign eq '+';
+ $sign . $MBI->_str($x->{_m}) . $sep . $MBI->_str($x->{_e});
+ }
+
+sub numify
+ {
+ # Make a number from a BigFloat object
+ # simple return a string and let Perl's atoi()/atof() handle the rest
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+ $x->bsstr();
+ }
+
+##############################################################################
+# public stuff (usually prefixed with "b")
+
+sub bneg
+ {
+ # (BINT or num_str) return BINT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
+ $x;
+ }
+
+# tels 2001-08-04
+# XXX TODO this must be overwritten and return NaN for non-integer values
+# band(), bior(), bxor(), too
+#sub bnot
+# {
+# $class->SUPER::bnot($class,@_);
+# }
+
+sub bcmp
+ {
+ # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bcmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # shortcut
+ my $xz = $x->is_zero();
+ my $yz = $y->is_zero();
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y
+ return 1 if $yz && $x->{sign} eq '+'; # +x <=> 0
+
+ # adjust so that exponents are equal
+ my $lxm = $MBI->_len($x->{_m});
+ my $lym = $MBI->_len($y->{_m});
+ # the numify somewhat limits our length, but makes it much faster
+ my ($xes,$yes) = (1,1);
+ $xes = -1 if $x->{_es} ne '+';
+ $yes = -1 if $y->{_es} ne '+';
+ my $lx = $lxm + $xes * $MBI->_num($x->{_e});
+ my $ly = $lym + $yes * $MBI->_num($y->{_e});
+ my $l = $lx - $ly; $l = -$l if $x->{sign} eq '-';
+ return $l <=> 0 if $l != 0;
+
+ # lengths (corrected by exponent) are equal
+ # so make mantissa equal length by padding with zero (shift left)
+ my $diff = $lxm - $lym;
+ my $xm = $x->{_m}; # not yet copy it
+ my $ym = $y->{_m};
+ if ($diff > 0)
+ {
+ $ym = $MBI->_copy($y->{_m});
+ $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
+ }
+ elsif ($diff < 0)
+ {
+ $xm = $MBI->_copy($x->{_m});
+ $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
+ }
+ my $rc = $MBI->_acmp($xm,$ym);
+ $rc = -$rc if $x->{sign} eq '-'; # -124 < -123
+ $rc <=> 0;
+ }
+
+sub bacmp
+ {
+ # Compares 2 values, ignoring their signs.
+ # Returns one of undef, <0, =0, >0. (suitable for sort)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bacmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # handle +-inf and NaN's
+ if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/)
+ {
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if ($x->is_inf() && $y->is_inf());
+ return 1 if ($x->is_inf() && !$y->is_inf());
+ return -1;
+ }
+
+ # shortcut
+ my $xz = $x->is_zero();
+ my $yz = $y->is_zero();
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && !$yz; # 0 <=> +y
+ return 1 if $yz && !$xz; # +x <=> 0
+
+ # adjust so that exponents are equal
+ my $lxm = $MBI->_len($x->{_m});
+ my $lym = $MBI->_len($y->{_m});
+ my ($xes,$yes) = (1,1);
+ $xes = -1 if $x->{_es} ne '+';
+ $yes = -1 if $y->{_es} ne '+';
+ # the numify somewhat limits our length, but makes it much faster
+ my $lx = $lxm + $xes * $MBI->_num($x->{_e});
+ my $ly = $lym + $yes * $MBI->_num($y->{_e});
+ my $l = $lx - $ly;
+ return $l <=> 0 if $l != 0;
+
+ # lengths (corrected by exponent) are equal
+ # so make mantissa equal-length by padding with zero (shift left)
+ my $diff = $lxm - $lym;
+ my $xm = $x->{_m}; # not yet copy it
+ my $ym = $y->{_m};
+ if ($diff > 0)
+ {
+ $ym = $MBI->_copy($y->{_m});
+ $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
+ }
+ elsif ($diff < 0)
+ {
+ $xm = $MBI->_copy($x->{_m});
+ $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
+ }
+ $MBI->_acmp($xm,$ym);
+ }
+
+sub badd
+ {
+ # add second arg (BFLOAT or string) to first (BFLOAT) (modifies first)
+ # return result as BFLOAT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('badd');
+
+ # inf and NaN handling
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # NaN first
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +inf++inf or -inf+-inf => same, rest is NaN
+ return $x if $x->{sign} eq $y->{sign};
+ return $x->bnan();
+ }
+ # +-inf + something => +inf; something +-inf => +-inf
+ $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
+ return $x;
+ }
+
+ return $upgrade->badd($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ $r[3] = $y; # no push!
+
+ # speed: no add for 0+y or x+0
+ return $x->bround(@r) if $y->is_zero(); # x+0
+ if ($x->is_zero()) # 0+y
+ {
+ # make copy, clobbering up x (modify in place!)
+ $x->{_e} = $MBI->_copy($y->{_e});
+ $x->{_es} = $y->{_es};
+ $x->{_m} = $MBI->_copy($y->{_m});
+ $x->{sign} = $y->{sign} || $nan;
+ return $x->round(@r);
+ }
+
+ # take lower of the two e's and adapt m1 to it to match m2
+ my $e = $y->{_e};
+ $e = $MBI->_zero() if !defined $e; # if no BFLOAT?
+ $e = $MBI->_copy($e); # make copy (didn't do it yet)
+
+ my $es;
+
+ ($e,$es) = _e_sub($e, $x->{_e}, $y->{_es} || '+', $x->{_es});
+
+ my $add = $MBI->_copy($y->{_m});
+
+ if ($es eq '-') # < 0
+ {
+ $MBI->_lsft( $x->{_m}, $e, 10);
+ ($x->{_e},$x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es);
+ }
+ elsif (!$MBI->_is_zero($e)) # > 0
+ {
+ $MBI->_lsft($add, $e, 10);
+ }
+ # else: both e are the same, so just leave them
+
+ if ($x->{sign} eq $y->{sign})
+ {
+ # add
+ $x->{_m} = $MBI->_add($x->{_m}, $add);
+ }
+ else
+ {
+ ($x->{_m}, $x->{sign}) =
+ _e_add($x->{_m}, $add, $x->{sign}, $y->{sign});
+ }
+
+ # delete trailing zeros, then round
+ $x->bnorm()->round(@r);
+ }
+
+# sub bsub is inherited from Math::BigInt!
+
+sub binc
+ {
+ # increment arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('binc');
+
+ if ($x->{_es} eq '-')
+ {
+ return $x->badd($self->bone(),@r); # digits after dot
+ }
+
+ if (!$MBI->_is_zero($x->{_e})) # _e == 0 for NaN, inf, -inf
+ {
+ # 1e2 => 100, so after the shift below _m has a '0' as last digit
+ $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10); # 1e2 => 100
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ # we know that the last digit of $x will be '1' or '9', depending on the
+ # sign
+ }
+ # now $x->{_e} == 0
+ if ($x->{sign} eq '+')
+ {
+ $MBI->_inc($x->{_m});
+ return $x->bnorm()->bround(@r);
+ }
+ elsif ($x->{sign} eq '-')
+ {
+ $MBI->_dec($x->{_m});
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # -1 +1 => -0 => +0
+ return $x->bnorm()->bround(@r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone(),@r); # badd() does round
+ }
+
+sub bdec
+ {
+ # decrement arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bdec');
+
+ if ($x->{_es} eq '-')
+ {
+ return $x->badd($self->bone('-'),@r); # digits after dot
+ }
+
+ if (!$MBI->_is_zero($x->{_e}))
+ {
+ $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10); # 1e2 => 100
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ }
+ # now $x->{_e} == 0
+ my $zero = $x->is_zero();
+ # <= 0
+ if (($x->{sign} eq '-') || $zero)
+ {
+ $MBI->_inc($x->{_m});
+ $x->{sign} = '-' if $zero; # 0 => 1 => -1
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # -1 +1 => -0 => +0
+ return $x->bnorm()->round(@r);
+ }
+ # > 0
+ elsif ($x->{sign} eq '+')
+ {
+ $MBI->_dec($x->{_m});
+ return $x->bnorm()->round(@r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone('-'),@r); # does round
+ }
+
+sub DEBUG () { 0; }
+
+sub blog
+ {
+ my ($self,$x,$base,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('blog');
+
+ # $base > 0, $base != 1; if $base == undef default to $base == e
+ # $x >= 0
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x->bnan() if $x->{sign} ne '+' || $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bzero(@params) if $x->is_one();
+ # base not defined => base == Euler's number e
+ if (defined $base)
+ {
+ # make object, since we don't feed it through objectify() to still get the
+ # case of $base == undef
+ $base = $self->new($base) unless ref($base);
+ # $base > 0; $base != 1
+ return $x->bnan() if $base->is_zero() || $base->is_one() ||
+ $base->{sign} ne '+';
+ # if $x == $base, we know the result must be 1.0
+ if ($x->bcmp($base) == 0)
+ {
+ $x->bone('+',@params);
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ return $x;
+ }
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+
+ # upgrade $x if $x is not a BigFloat (handle BigInt input)
+ # XXX TODO: rebless!
+ if (!$x->isa('Math::BigFloat'))
+ {
+ $x = Math::BigFloat->new($x);
+ $self = ref($x);
+ }
+
+ my $done = 0;
+
+ # If the base is defined and an integer, try to calculate integer result
+ # first. This is very fast, and in case the real result was found, we can
+ # stop right here.
+ if (defined $base && $base->is_int() && $x->is_int())
+ {
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $int = Math::BigInt->bzero();
+ $int->{value} = $i;
+ $int->blog($base->as_number());
+ # if ($exact)
+ if ($base->as_number()->bpow($int) == $x)
+ {
+ # found result, return it
+ $x->{_m} = $int->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->bnorm();
+ $done = 1;
+ }
+ }
+
+ if ($done == 0)
+ {
+ # base is undef, so base should be e (Euler's number), so first calculate the
+ # log to base e (using reduction by 10 (and probably 2)):
+ $self->_log_10($x,$scale);
+
+ # and if a different base was requested, convert it
+ if (defined $base)
+ {
+ $base = Math::BigFloat->new($base) unless $base->isa('Math::BigFloat');
+ # not ln, but some other base (don't modify $base)
+ $x->bdiv( $base->copy()->blog(undef,$scale), $scale );
+ }
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+
+ $x;
+ }
+
+sub _len_to_steps
+ {
+ # Given D (digits in decimal), compute N so that N! (N factorial) is
+ # at least D digits long. D should be at least 50.
+ my $d = shift;
+
+ # two constants for the Ramanujan estimate of ln(N!)
+ my $lg2 = log(2 * 3.14159265) / 2;
+ my $lg10 = log(10);
+
+ # D = 50 => N => 42, so L = 40 and R = 50
+ my $l = 40; my $r = $d;
+
+ # Otherwise this does not work under -Mbignum and we do not yet have "no bignum;" :(
+ $l = $l->numify if ref($l);
+ $r = $r->numify if ref($r);
+ $lg2 = $lg2->numify if ref($lg2);
+ $lg10 = $lg10->numify if ref($lg10);
+
+ # binary search for the right value (could this be written as the reverse of lg(n!)?)
+ while ($r - $l > 1)
+ {
+ my $n = int(($r - $l) / 2) + $l;
+ my $ramanujan =
+ int(($n * log($n) - $n + log( $n * (1 + 4*$n*(1+2*$n)) ) / 6 + $lg2) / $lg10);
+ $ramanujan > $d ? $r = $n : $l = $n;
+ }
+ $l;
+ }
+
+sub bnok
+ {
+ # Calculate n over k (binomial coefficient or "choose" function) as integer.
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bnok');
+
+ return $x->bnan() if $x->is_nan() || $y->is_nan();
+ return $x->binf() if $x->is_inf();
+
+ my $u = $x->as_int();
+ $u->bnok($y->as_int());
+
+ $x->{_m} = $u->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->{sign} = '+';
+ $x->bnorm(@r);
+ }
+
+sub bexp
+ {
+ # Calculate e ** X (Euler's number to the power of X)
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bexp');
+
+ return $x->binf() if $x->{sign} eq '+inf';
+ return $x->bzero() if $x->{sign} eq '-inf';
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x if $x->{sign} eq 'NaN';
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it's not enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bone(@params) if $x->is_zero();
+
+ if (!$x->isa('Math::BigFloat'))
+ {
+ $x = Math::BigFloat->new($x);
+ $self = ref($x);
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+
+ my $x_org = $x->copy();
+
+ # We use the following Taylor series:
+
+ # x x^2 x^3 x^4
+ # e = 1 + --- + --- + --- + --- ...
+ # 1! 2! 3! 4!
+
+ # The difference for each term is X and N, which would result in:
+ # 2 copy, 2 mul, 2 add, 1 inc, 1 div operations per term
+
+ # But it is faster to compute exp(1) and then raising it to the
+ # given power, esp. if $x is really big and an integer because:
+
+ # * The numerator is always 1, making the computation faster
+ # * the series converges faster in the case of x == 1
+ # * We can also easily check when we have reached our limit: when the
+ # term to be added is smaller than "1E$scale", we can stop - f.i.
+ # scale == 5, and we have 1/40320, then we stop since 1/40320 < 1E-5.
+ # * we can compute the *exact* result by simulating bigrat math:
+
+ # 1 1 gcd(3,4) = 1 1*24 + 1*6 5
+ # - + - = ---------- = --
+ # 6 24 6*24 24
+
+ # We do not compute the gcd() here, but simple do:
+ # 1 1 1*24 + 1*6 30
+ # - + - = --------- = --
+ # 6 24 6*24 144
+
+ # In general:
+ # a c a*d + c*b and note that c is always 1 and d = (b*f)
+ # - + - = ---------
+ # b d b*d
+
+ # This leads to: which can be reduced by b to:
+ # a 1 a*b*f + b a*f + 1
+ # - + - = --------- = -------
+ # b b*f b*b*f b*f
+
+ # The first terms in the series are:
+
+ # 1 1 1 1 1 1 1 1 13700
+ # -- + -- + -- + -- + -- + --- + --- + ---- = -----
+ # 1 1 2 6 24 120 720 5040 5040
+
+ # Note that we cannot simple reduce 13700/5040 to 685/252, but must keep A and B!
+
+ if ($scale <= 75)
+ {
+ # set $x directly from a cached string form
+ $x->{_m} = $MBI->_new(
+ "27182818284590452353602874713526624977572470936999595749669676277240766303535476");
+ $x->{sign} = '+';
+ $x->{_es} = '-';
+ $x->{_e} = $MBI->_new(79);
+ }
+ else
+ {
+ # compute A and B so that e = A / B.
+
+ # After some terms we end up with this, so we use it as a starting point:
+ my $A = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ my $F = $MBI->_new(42); my $step = 42;
+
+ # Compute how many steps we need to take to get $A and $B sufficiently big
+ my $steps = _len_to_steps($scale - 4);
+# print STDERR "# Doing $steps steps for ", $scale-4, " digits\n";
+ while ($step++ <= $steps)
+ {
+ # calculate $a * $f + 1
+ $A = $MBI->_mul($A, $F);
+ $A = $MBI->_inc($A);
+ # increment f
+ $F = $MBI->_inc($F);
+ }
+ # compute $B as factorial of $steps (this is faster than doing it manually)
+ my $B = $MBI->_fac($MBI->_new($steps));
+
+# print "A ", $MBI->_str($A), "\nB ", $MBI->_str($B), "\n";
+
+ # compute A/B with $scale digits in the result (truncate, not round)
+ $A = $MBI->_lsft( $A, $MBI->_new($scale), 10);
+ $A = $MBI->_div( $A, $B );
+
+ $x->{_m} = $A;
+ $x->{sign} = '+';
+ $x->{_es} = '-';
+ $x->{_e} = $MBI->_new($scale);
+ }
+
+ # $x contains now an estimate of e, with some surplus digits, so we can round
+ if (!$x_org->is_one())
+ {
+ # raise $x to the wanted power and round it in one step:
+ $x->bpow($x_org, @params);
+ }
+ else
+ {
+ # else just round the already computed result
+ delete $x->{_a}; delete $x->{_p};
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+
+ $x; # return modified $x
+ }
+
+sub _log
+ {
+ # internal log function to calculate ln() based on Taylor series.
+ # Modifies $x in place.
+ my ($self,$x,$scale) = @_;
+
+ # in case of $x == 1, result is 0
+ return $x->bzero() if $x->is_one();
+
+ # XXX TODO: rewrite this in a similiar manner to bexp()
+
+ # http://www.efunda.com/math/taylor_series/logarithmic.cfm?search_string=log
+
+ # u = x-1, v = x+1
+ # _ _
+ # Taylor: | u 1 u^3 1 u^5 |
+ # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 0
+ # |_ v 3 v^3 5 v^5 _|
+
+ # This takes much more steps to calculate the result and is thus not used
+ # u = x-1
+ # _ _
+ # Taylor: | u 1 u^2 1 u^3 |
+ # ln (x) = 2 | --- + - * --- + - * --- + ... | x > 1/2
+ # |_ x 2 x^2 3 x^3 _|
+
+ my ($limit,$v,$u,$below,$factor,$two,$next,$over,$f);
+
+ $v = $x->copy(); $v->binc(); # v = x+1
+ $x->bdec(); $u = $x->copy(); # u = x-1; x = x-1
+ $x->bdiv($v,$scale); # first term: u/v
+ $below = $v->copy();
+ $over = $u->copy();
+ $u *= $u; $v *= $v; # u^2, v^2
+ $below->bmul($v); # u^3, v^3
+ $over->bmul($u);
+ $factor = $self->new(3); $f = $self->new(2);
+
+ my $steps = 0 if DEBUG;
+ $limit = $self->new("1E-". ($scale-1));
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop
+
+ # calculating the next term simple from over/below will result in quite
+ # a time hog if the input has many digits, since over and below will
+ # accumulate more and more digits, and the result will also have many
+ # digits, but in the end it is rounded to $scale digits anyway. So if we
+ # round $over and $below first, we save a lot of time for the division
+ # (not with log(1.2345), but try log (123**123) to see what I mean. This
+ # can introduce a rounding error if the division result would be f.i.
+ # 0.1234500000001 and we round it to 5 digits it would become 0.12346, but
+ # if we truncated $over and $below we might get 0.12345. Does this matter
+ # for the end result? So we give $over and $below 4 more digits to be
+ # on the safe side (unscientific error handling as usual... :+D
+
+ $next = $over->copy->bround($scale+4)->bdiv(
+ $below->copy->bmul($factor)->bround($scale+4),
+ $scale);
+
+## old version:
+## $next = $over->copy()->bdiv($below->copy()->bmul($factor),$scale);
+
+ last if $next->bacmp($limit) <= 0;
+
+ delete $next->{_a}; delete $next->{_p};
+ $x->badd($next);
+ # calculate things for the next term
+ $over *= $u; $below *= $v; $factor->badd($f);
+ if (DEBUG)
+ {
+ $steps++; print "step $steps = $x\n" if $steps % 10 == 0;
+ }
+ }
+ print "took $steps steps\n" if DEBUG;
+ $x->bmul($f); # $x *= 2
+ }
+
+sub _log_10
+ {
+ # Internal log function based on reducing input to the range of 0.1 .. 9.99
+ # and then "correcting" the result to the proper one. Modifies $x in place.
+ my ($self,$x,$scale) = @_;
+
+ # Taking blog() from numbers greater than 10 takes a *very long* time, so we
+ # break the computation down into parts based on the observation that:
+ # blog(X*Y) = blog(X) + blog(Y)
+ # We set Y here to multiples of 10 so that $x becomes below 1 - the smaller
+ # $x is the faster it gets. Since 2*$x takes about 10 times as
+ # long, we make it faster by about a factor of 100 by dividing $x by 10.
+
+ # The same observation is valid for numbers smaller than 0.1, e.g. computing
+ # log(1) is fastest, and the further away we get from 1, the longer it takes.
+ # So we also 'break' this down by multiplying $x with 10 and subtract the
+ # log(10) afterwards to get the correct result.
+
+ # To get $x even closer to 1, we also divide by 2 and then use log(2) to
+ # correct for this. For instance if $x is 2.4, we use the formula:
+ # blog(2.4 * 2) == blog (1.2) + blog(2)
+ # and thus calculate only blog(1.2) and blog(2), which is faster in total
+ # than calculating blog(2.4).
+
+ # In addition, the values for blog(2) and blog(10) are cached.
+
+ # Calculate nr of digits before dot:
+ my $dbd = $MBI->_num($x->{_e});
+ $dbd = -$dbd if $x->{_es} eq '-';
+ $dbd += $MBI->_len($x->{_m});
+
+ # more than one digit (e.g. at least 10), but *not* exactly 10 to avoid
+ # infinite recursion
+
+ my $calc = 1; # do some calculation?
+
+ # disable the shortcut for 10, since we need log(10) and this would recurse
+ # infinitely deep
+ if ($x->{_es} eq '+' && $MBI->_is_one($x->{_e}) && $MBI->_is_one($x->{_m}))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_10_A)
+ {
+ $x->bzero(); $x->badd($LOG_10); # modify $x in place
+ $calc = 0; # no need to calc, but round
+ }
+ # if we can't use the shortcut, we continue normally
+ }
+ else
+ {
+ # disable the shortcut for 2, since we maybe have it cached
+ if (($MBI->_is_zero($x->{_e}) && $MBI->_is_two($x->{_m})))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_2_A)
+ {
+ $x->bzero(); $x->badd($LOG_2); # modify $x in place
+ $calc = 0; # no need to calc, but round
+ }
+ # if we can't use the shortcut, we continue normally
+ }
+ }
+
+ # if $x = 0.1, we know the result must be 0-log(10)
+ if ($calc != 0 && $x->{_es} eq '-' && $MBI->_is_one($x->{_e}) &&
+ $MBI->_is_one($x->{_m}))
+ {
+ $dbd = 0; # disable shortcut
+ # we can use the cached value in these cases
+ if ($scale <= $LOG_10_A)
+ {
+ $x->bzero(); $x->bsub($LOG_10);
+ $calc = 0; # no need to calc, but round
+ }
+ }
+
+ return if $calc == 0; # already have the result
+
+ # default: these correction factors are undef and thus not used
+ my $l_10; # value of ln(10) to A of $scale
+ my $l_2; # value of ln(2) to A of $scale
+
+ my $two = $self->new(2);
+
+ # $x == 2 => 1, $x == 13 => 2, $x == 0.1 => 0, $x == 0.01 => -1
+ # so don't do this shortcut for 1 or 0
+ if (($dbd > 1) || ($dbd < 0))
+ {
+ # convert our cached value to an object if not already (avoid doing this
+ # at import() time, since not everybody needs this)
+ $LOG_10 = $self->new($LOG_10,undef,undef) unless ref $LOG_10;
+
+ #print "x = $x, dbd = $dbd, calc = $calc\n";
+ # got more than one digit before the dot, or more than one zero after the
+ # dot, so do:
+ # log(123) == log(1.23) + log(10) * 2
+ # log(0.0123) == log(1.23) - log(10) * 2
+
+ if ($scale <= $LOG_10_A)
+ {
+ # use cached value
+ $l_10 = $LOG_10->copy(); # copy for mul
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ # also disable downgrade for this code path
+ local $Math::BigFloat::downgrade = undef;
+
+ # shorten the time to calculate log(10) based on the following:
+ # log(1.25 * 8) = log(1.25) + log(8)
+ # = log(1.25) + log(2) + log(2) + log(2)
+
+ # first get $l_2 (and possible compute and cache log(2))
+ $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
+ if ($scale <= $LOG_2_A)
+ {
+ # use cached value
+ $l_2 = $LOG_2->copy(); # copy() for the mul below
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
+ $LOG_2 = $l_2->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_2_A = $scale;
+ }
+
+ # now calculate log(1.25):
+ $l_10 = $self->new('1.25'); $self->_log($l_10, $scale); # scale+4, actually
+
+ # log(1.25) + log(2) + log(2) + log(2):
+ $l_10->badd($l_2);
+ $l_10->badd($l_2);
+ $l_10->badd($l_2);
+ $LOG_10 = $l_10->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_10_A = $scale;
+ }
+ $dbd-- if ($dbd > 1); # 20 => dbd=2, so make it dbd=1
+ $l_10->bmul( $self->new($dbd)); # log(10) * (digits_before_dot-1)
+ my $dbd_sign = '+';
+ if ($dbd < 0)
+ {
+ $dbd = -$dbd;
+ $dbd_sign = '-';
+ }
+ ($x->{_e}, $x->{_es}) =
+ _e_sub( $x->{_e}, $MBI->_new($dbd), $x->{_es}, $dbd_sign); # 123 => 1.23
+
+ }
+
+ # Now: 0.1 <= $x < 10 (and possible correction in l_10)
+
+ ### Since $x in the range 0.5 .. 1.5 is MUCH faster, we do a repeated div
+ ### or mul by 2 (maximum times 3, since x < 10 and x > 0.1)
+
+ $HALF = $self->new($HALF) unless ref($HALF);
+
+ my $twos = 0; # default: none (0 times)
+ while ($x->bacmp($HALF) <= 0) # X <= 0.5
+ {
+ $twos--; $x->bmul($two);
+ }
+ while ($x->bacmp($two) >= 0) # X >= 2
+ {
+ $twos++; $x->bdiv($two,$scale+4); # keep all digits
+ }
+ # $twos > 0 => did mul 2, < 0 => did div 2 (but we never did both)
+ # So calculate correction factor based on ln(2):
+ if ($twos != 0)
+ {
+ $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
+ if ($scale <= $LOG_2_A)
+ {
+ # use cached value
+ $l_2 = $LOG_2->copy(); # copy() for the mul below
+ }
+ else
+ {
+ # else: slower, compute and cache result
+ # also disable downgrade for this code path
+ local $Math::BigFloat::downgrade = undef;
+ $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
+ $LOG_2 = $l_2->copy(); # cache the result for later
+ # the copy() is for mul below
+ $LOG_2_A = $scale;
+ }
+ $l_2->bmul($twos); # * -2 => subtract, * 2 => add
+ }
+
+ $self->_log($x,$scale); # need to do the "normal" way
+ $x->badd($l_10) if defined $l_10; # correct it by ln(10)
+ $x->badd($l_2) if defined $l_2; # and maybe by ln(2)
+
+ # all done, $x contains now the result
+ $x;
+ }
+
+sub blcm
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # does not modify arguments, but returns new object
+ # Lowest Common Multiplicator
+
+ my ($self,@arg) = objectify(0,@_);
+ my $x = $self->new(shift @arg);
+ while (@arg) { $x = Math::BigInt::__lcm($x,shift @arg); }
+ $x;
+ }
+
+sub bgcd
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+
+ my $y = shift;
+ $y = __PACKAGE__->new($y) if !ref($y);
+ my $self = ref($y);
+ my $x = $y->copy()->babs(); # keep arguments
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]$/ # x NaN?
+ || !$x->is_int(); # only for integers now
+
+ while (@_)
+ {
+ my $t = shift; $t = $self->new($t) if !ref($t);
+ $y = $t->copy()->babs();
+
+ return $x->bnan() if $y->{sign} !~ /^[+-]$/ # y NaN?
+ || !$y->is_int(); # only for integers now
+
+ # greatest common divisor
+ while (! $y->is_zero())
+ {
+ ($x,$y) = ($y->copy(), $x->copy()->bmod($y));
+ }
+
+ last if $x->is_one();
+ }
+ $x;
+ }
+
+##############################################################################
+
+sub _e_add
+ {
+ # Internal helper sub to take two positive integers and their signs and
+ # then add them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')),
+ # output ($CALC,('+'|'-'))
+ my ($x,$y,$xs,$ys) = @_;
+
+ # if the signs are equal we can add them (-5 + -3 => -(5 + 3) => -8)
+ if ($xs eq $ys)
+ {
+ $x = $MBI->_add ($x, $y ); # a+b
+ # the sign follows $xs
+ return ($x, $xs);
+ }
+
+ my $a = $MBI->_acmp($x,$y);
+ if ($a > 0)
+ {
+ $x = $MBI->_sub ($x , $y); # abs sub
+ }
+ elsif ($a == 0)
+ {
+ $x = $MBI->_zero(); # result is 0
+ $xs = '+';
+ }
+ else # a < 0
+ {
+ $x = $MBI->_sub ( $y, $x, 1 ); # abs sub
+ $xs = $ys;
+ }
+ ($x,$xs);
+ }
+
+sub _e_sub
+ {
+ # Internal helper sub to take two positive integers and their signs and
+ # then subtract them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')),
+ # output ($CALC,('+'|'-'))
+ my ($x,$y,$xs,$ys) = @_;
+
+ # flip sign
+ $ys =~ tr/+-/-+/;
+ _e_add($x,$y,$xs,$ys); # call add (does subtract now)
+ }
+
+###############################################################################
+# is_foo methods (is_negative, is_positive are inherited from BigInt)
+
+sub is_int
+ {
+ # return true if arg (BFLOAT or num_str) is an integer
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't
+ ($x->{_es} eq '+')) ? 1 : 0; # 1e-1 => no integer
+ }
+
+sub is_zero
+ {
+ # return true if arg (BFLOAT or num_str) is zero
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m})) ? 1 : 0;
+ }
+
+sub is_one
+ {
+ # return true if arg (BFLOAT or num_str) is +1 or -1 if signis given
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $sign = '+' if !defined $sign || $sign ne '-';
+
+ ($x->{sign} eq $sign &&
+ $MBI->_is_zero($x->{_e}) &&
+ $MBI->_is_one($x->{_m}) ) ? 1 : 0;
+ }
+
+sub is_odd
+ {
+ # return true if arg (BFLOAT or num_str) is odd or false if even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($MBI->_is_zero($x->{_e})) &&
+ ($MBI->_is_odd($x->{_m}))) ? 1 : 0;
+ }
+
+sub is_even
+ {
+ # return true if arg (BINT or num_str) is even or false if odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ (($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($x->{_es} eq '+') && # 123.45 isn't
+ ($MBI->_is_even($x->{_m}))) ? 1 : 0; # but 1200 is
+ }
+
+sub bmul
+ {
+ # multiply two numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmul');
+
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # aEb * cEd = (a*c)E(b+d)
+ $MBI->_mul($x->{_m},$y->{_m});
+ ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+
+ $r[3] = $y; # no push!
+
+ # adjust sign:
+ $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
+ $x->bnorm->round(@r);
+ }
+
+sub bmuladd
+ {
+ # multiply two numbers and add the third to the result
+
+ # set up parameters
+ my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$z,@r) = objectify(3,@_);
+ }
+
+ return $x if $x->modify('bmuladd');
+
+ return $x->bnan() if (($x->{sign} eq $nan) ||
+ ($y->{sign} eq $nan) ||
+ ($z->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ # aEb * cEd = (a*c)E(b+d)
+ $MBI->_mul($x->{_m},$y->{_m});
+ ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+
+ $r[3] = $y; # no push!
+
+ # adjust sign:
+ $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
+
+ # z=inf handling (z=NaN handled above)
+ $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
+
+ # take lower of the two e's and adapt m1 to it to match m2
+ my $e = $z->{_e};
+ $e = $MBI->_zero() if !defined $e; # if no BFLOAT?
+ $e = $MBI->_copy($e); # make copy (didn't do it yet)
+
+ my $es;
+
+ ($e,$es) = _e_sub($e, $x->{_e}, $z->{_es} || '+', $x->{_es});
+
+ my $add = $MBI->_copy($z->{_m});
+
+ if ($es eq '-') # < 0
+ {
+ $MBI->_lsft( $x->{_m}, $e, 10);
+ ($x->{_e},$x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es);
+ }
+ elsif (!$MBI->_is_zero($e)) # > 0
+ {
+ $MBI->_lsft($add, $e, 10);
+ }
+ # else: both e are the same, so just leave them
+
+ if ($x->{sign} eq $z->{sign})
+ {
+ # add
+ $x->{_m} = $MBI->_add($x->{_m}, $add);
+ }
+ else
+ {
+ ($x->{_m}, $x->{sign}) =
+ _e_add($x->{_m}, $add, $x->{sign}, $z->{sign});
+ }
+
+ # delete trailing zeros, then round
+ $x->bnorm()->round(@r);
+ }
+
+sub bdiv
+ {
+ # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return
+ # (BFLOAT,BFLOAT) (quo,rem) or BFLOAT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bdiv');
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # upgrade ?
+ return $upgrade->bdiv($upgrade->new($x),$y,$a,$p,$r) if defined $upgrade;
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r,$y);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ my $rem; $rem = $self->bzero() if wantarray;
+
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ my $lx = $MBI->_len($x->{_m}); my $ly = $MBI->_len($y->{_m});
+ $scale = $lx if $lx > $scale;
+ $scale = $ly if $ly > $scale;
+ my $diff = $ly - $lx;
+ $scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx!
+
+ # already handled inf/NaN/-inf above:
+
+ # check that $y is not 1 nor -1 and cache the result:
+ my $y_not_one = !($MBI->_is_zero($y->{_e}) && $MBI->_is_one($y->{_m}));
+
+ # flipping the sign of $y will also flip the sign of $x for the special
+ # case of $x->bsub($x); so we can catch it below:
+ my $xsign = $x->{sign};
+ $y->{sign} =~ tr/+-/-+/;
+
+ if ($xsign ne $x->{sign})
+ {
+ # special case of $x /= $x results in 1
+ $x->bone(); # "fixes" also sign of $y, since $x is $y
+ }
+ else
+ {
+ # correct $y's sign again
+ $y->{sign} =~ tr/+-/-+/;
+ # continue with normal div code:
+
+ # make copy of $x in case of list context for later reminder calculation
+ if (wantarray && $y_not_one)
+ {
+ $rem = $x->copy();
+ }
+
+ $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+';
+
+ # check for / +-1 ( +/- 1E0)
+ if ($y_not_one)
+ {
+ # promote BigInts and it's subclasses (except when already a BigFloat)
+ $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
+ # calculate the result to $scale digits and then round it
+ # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
+ $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
+ $MBI->_div ($x->{_m},$y->{_m}); # a/c
+
+ # correct exponent of $x
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+ # correct for 10**scale
+ ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
+ $x->bnorm(); # remove trailing 0's
+ }
+ } # ende else $x != $y
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ delete $x->{_a}; # clear before round
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ delete $x->{_p}; # clear before round
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+
+ if (wantarray)
+ {
+ if ($y_not_one)
+ {
+ $rem->bmod($y,@params); # copy already done
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $rem->{_a}; delete $rem->{_p};
+ }
+ return ($x,$rem);
+ }
+ $x;
+ }
+
+sub bmod
+ {
+ # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return reminder
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmod');
+
+ # handle NaN, inf, -inf
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ my ($d,$re) = $self->SUPER::_div_inf($x,$y);
+ $x->{sign} = $re->{sign};
+ $x->{_e} = $re->{_e};
+ $x->{_m} = $re->{_m};
+ return $x->round($a,$p,$r,$y);
+ }
+ if ($y->is_zero())
+ {
+ return $x->bnan() if $x->is_zero();
+ return $x;
+ }
+
+ return $x->bzero() if $x->is_zero()
+ || ($x->is_int() &&
+ # check that $y == +1 or $y == -1:
+ ($MBI->_is_zero($y->{_e}) && $MBI->_is_one($y->{_m})));
+
+ my $cmp = $x->bacmp($y); # equal or $x < $y?
+ return $x->bzero($a,$p) if $cmp == 0; # $x == $y => result 0
+
+ # only $y of the operands negative?
+ my $neg = 0; $neg = 1 if $x->{sign} ne $y->{sign};
+
+ $x->{sign} = $y->{sign}; # calc sign first
+ return $x->round($a,$p,$r) if $cmp < 0 && $neg == 0; # $x < $y => result $x
+
+ my $ym = $MBI->_copy($y->{_m});
+
+ # 2e1 => 20
+ $MBI->_lsft( $ym, $y->{_e}, 10)
+ if $y->{_es} eq '+' && !$MBI->_is_zero($y->{_e});
+
+ # if $y has digits after dot
+ my $shifty = 0; # correct _e of $x by this
+ if ($y->{_es} eq '-') # has digits after dot
+ {
+ # 123 % 2.5 => 1230 % 25 => 5 => 0.5
+ $shifty = $MBI->_num($y->{_e}); # no more digits after dot
+ $MBI->_lsft($x->{_m}, $y->{_e}, 10);# 123 => 1230, $y->{_m} is already 25
+ }
+ # $ym is now mantissa of $y based on exponent 0
+
+ my $shiftx = 0; # correct _e of $x by this
+ if ($x->{_es} eq '-') # has digits after dot
+ {
+ # 123.4 % 20 => 1234 % 200
+ $shiftx = $MBI->_num($x->{_e}); # no more digits after dot
+ $MBI->_lsft($ym, $x->{_e}, 10); # 123 => 1230
+ }
+ # 123e1 % 20 => 1230 % 20
+ if ($x->{_es} eq '+' && !$MBI->_is_zero($x->{_e}))
+ {
+ $MBI->_lsft( $x->{_m}, $x->{_e},10); # es => '+' here
+ }
+
+ $x->{_e} = $MBI->_new($shiftx);
+ $x->{_es} = '+';
+ $x->{_es} = '-' if $shiftx != 0 || $shifty != 0;
+ $MBI->_add( $x->{_e}, $MBI->_new($shifty)) if $shifty != 0;
+
+ # now mantissas are equalized, exponent of $x is adjusted, so calc result
+
+ $x->{_m} = $MBI->_mod( $x->{_m}, $ym);
+
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # fix sign for -0
+ $x->bnorm();
+
+ if ($neg != 0) # one of them negative => correct in place
+ {
+ my $r = $y - $x;
+ $x->{_m} = $r->{_m};
+ $x->{_e} = $r->{_e};
+ $x->{_es} = $r->{_es};
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # fix sign for -0
+ $x->bnorm();
+ }
+
+ $x->round($a,$p,$r,$y); # round and return
+ }
+
+sub broot
+ {
+ # calculate $y'th root of $x
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('broot');
+
+ # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
+ return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
+ $y->{sign} !~ /^\+$/;
+
+ return $x if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # iound mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI
+
+ # remember sign and make $x positive, since -4 ** (1/2) => -2
+ my $sign = 0; $sign = 1 if $x->{sign} eq '-'; $x->{sign} = '+';
+
+ my $is_two = 0;
+ if ($y->isa('Math::BigFloat'))
+ {
+ $is_two = ($y->{sign} eq '+' && $MBI->_is_two($y->{_m}) && $MBI->_is_zero($y->{_e}));
+ }
+ else
+ {
+ $is_two = ($y == 2);
+ }
+
+ # normal square root if $y == 2:
+ if ($is_two)
+ {
+ $x->bsqrt($scale+4);
+ }
+ elsif ($y->is_one('-'))
+ {
+ # $x ** -1 => 1/$x
+ my $u = $self->bone()->bdiv($x,$scale);
+ # copy private parts over
+ $x->{_m} = $u->{_m};
+ $x->{_e} = $u->{_e};
+ $x->{_es} = $u->{_es};
+ }
+ else
+ {
+ # calculate the broot() as integer result first, and if it fits, return
+ # it rightaway (but only if $x and $y are integer):
+
+ my $done = 0; # not yet
+ if ($y->is_int() && $x->is_int())
+ {
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $int = Math::BigInt->bzero();
+ $int->{value} = $i;
+ $int->broot($y->as_number());
+ # if ($exact)
+ if ($int->copy()->bpow($y) == $x)
+ {
+ # found result, return it
+ $x->{_m} = $int->{value};
+ $x->{_e} = $MBI->_zero();
+ $x->{_es} = '+';
+ $x->bnorm();
+ $done = 1;
+ }
+ }
+ if ($done == 0)
+ {
+ my $u = $self->bone()->bdiv($y,$scale+4);
+ delete $u->{_a}; delete $u->{_p}; # otherwise it conflicts
+ $x->bpow($u,$scale+4); # el cheapo
+ }
+ }
+ $x->bneg() if $sign == 1;
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bsqrt
+ {
+ # calculate square root
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsqrt');
+
+ return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0
+ return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf
+ return $x->round($a,$p,$r) if $x->is_zero() || $x->is_one();
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my (@params,$scale);
+ ($x,@params) = $x->_find_round_parameters($a,$p,$r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef; # should be really parent class vs MBI
+
+ my $i = $MBI->_copy( $x->{_m} );
+ $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
+ my $xas = Math::BigInt->bzero();
+ $xas->{value} = $i;
+
+ my $gs = $xas->copy()->bsqrt(); # some guess
+
+ if (($x->{_es} ne '-') # guess can't be accurate if there are
+ # digits after the dot
+ && ($xas->bacmp($gs * $gs) == 0)) # guess hit the nail on the head?
+ {
+ # exact result, copy result over to keep $x
+ $x->{_m} = $gs->{value}; $x->{_e} = $MBI->_zero(); $x->{_es} = '+';
+ $x->bnorm();
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # re-enable A and P, upgrade is taken care of by "local"
+ ${"$self\::accuracy"} = $ab; ${"$self\::precision"} = $pb;
+ return $x;
+ }
+
+ # sqrt(2) = 1.4 because sqrt(2*100) = 1.4*10; so we can increase the accuracy
+ # of the result by multipyling the input by 100 and then divide the integer
+ # result of sqrt(input) by 10. Rounding afterwards returns the real result.
+
+ # The following steps will transform 123.456 (in $x) into 123456 (in $y1)
+ my $y1 = $MBI->_copy($x->{_m});
+
+ my $length = $MBI->_len($y1);
+
+ # Now calculate how many digits the result of sqrt(y1) would have
+ my $digits = int($length / 2);
+
+ # But we need at least $scale digits, so calculate how many are missing
+ my $shift = $scale - $digits;
+
+ # This happens if the input had enough digits
+ # (we take care of integer guesses above)
+ $shift = 0 if $shift < 0;
+
+ # Multiply in steps of 100, by shifting left two times the "missing" digits
+ my $s2 = $shift * 2;
+
+ # We now make sure that $y1 has the same odd or even number of digits than
+ # $x had. So when _e of $x is odd, we must shift $y1 by one digit left,
+ # because we always must multiply by steps of 100 (sqrt(100) is 10) and not
+ # steps of 10. The length of $x does not count, since an even or odd number
+ # of digits before the dot is not changed by adding an even number of digits
+ # after the dot (the result is still odd or even digits long).
+ $s2++ if $MBI->_is_odd($x->{_e});
+
+ $MBI->_lsft( $y1, $MBI->_new($s2), 10);
+
+ # now take the square root and truncate to integer
+ $y1 = $MBI->_sqrt($y1);
+
+ # By "shifting" $y1 right (by creating a negative _e) we calculate the final
+ # result, which is than later rounded to the desired scale.
+
+ # calculate how many zeros $x had after the '.' (or before it, depending
+ # on sign of $dat, the result should have half as many:
+ my $dat = $MBI->_num($x->{_e});
+ $dat = -$dat if $x->{_es} eq '-';
+ $dat += $length;
+
+ if ($dat > 0)
+ {
+ # no zeros after the dot (e.g. 1.23, 0.49 etc)
+ # preserve half as many digits before the dot than the input had
+ # (but round this "up")
+ $dat = int(($dat+1)/2);
+ }
+ else
+ {
+ $dat = int(($dat)/2);
+ }
+ $dat -= $MBI->_len($y1);
+ if ($dat < 0)
+ {
+ $dat = abs($dat);
+ $x->{_e} = $MBI->_new( $dat );
+ $x->{_es} = '-';
+ }
+ else
+ {
+ $x->{_e} = $MBI->_new( $dat );
+ $x->{_es} = '+';
+ }
+ $x->{_m} = $y1;
+ $x->bnorm();
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bfac
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # compute factorial number, modifies first argument
+
+ # set up parameters
+ my ($self,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ ($self,$x,@r) = objectify(1,@_) if !ref($x);
+
+ # inf => inf
+ return $x if $x->modify('bfac') || $x->{sign} eq '+inf';
+
+ return $x->bnan()
+ if (($x->{sign} ne '+') || # inf, NaN, <0 etc => NaN
+ ($x->{_es} ne '+')); # digits after dot?
+
+ # use BigInt's bfac() for faster calc
+ if (! $MBI->_is_zero($x->{_e}))
+ {
+ $MBI->_lsft($x->{_m}, $x->{_e},10); # change 12e1 to 120e0
+ $x->{_e} = $MBI->_zero(); # normalize
+ $x->{_es} = '+';
+ }
+ $MBI->_fac($x->{_m}); # calculate factorial
+ $x->bnorm()->round(@r); # norm again and round result
+ }
+
+sub _pow
+ {
+ # Calculate a power where $y is a non-integer, like 2 ** 0.3
+ my ($x,$y,@r) = @_;
+ my $self = ref($x);
+
+ # if $y == 0.5, it is sqrt($x)
+ $HALF = $self->new($HALF) unless ref($HALF);
+ return $x->bsqrt(@r,$y) if $y->bcmp($HALF) == 0;
+
+ # Using:
+ # a ** x == e ** (x * ln a)
+
+ # u = y * ln x
+ # _ _
+ # Taylor: | u u^2 u^3 |
+ # x ** y = 1 + | --- + --- + ----- + ... |
+ # |_ 1 1*2 1*2*3 _|
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ return $x if $x->is_nan(); # error in _find_round_parameters?
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my ($limit,$v,$u,$below,$factor,$next,$over);
+
+ $u = $x->copy()->blog(undef,$scale)->bmul($y);
+ $v = $self->bone(); # 1
+ $factor = $self->new(2); # 2
+ $x->bone(); # first term: 1
+
+ $below = $v->copy();
+ $over = $u->copy();
+
+ $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+ $x->badd($next);
+ # calculate things for the next term
+ $over *= $u; $below *= $factor; $factor->binc();
+
+ last if $x->{sign} !~ /^[-+]$/;
+
+ #$steps++;
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bpow
+ {
+ # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
+ # compute power of two numbers, second arg is used as integer
+ # modifies first argument
+
+ # set up parameters
+ my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bpow');
+
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+ return $x if $x->{sign} =~ /^[+-]inf$/;
+
+ # cache the result of is_zero
+ my $y_is_zero = $y->is_zero();
+ return $x->bone() if $y_is_zero;
+ return $x if $x->is_one() || $y->is_one();
+
+ my $x_is_zero = $x->is_zero();
+ return $x->_pow($y,$a,$p,$r) if !$x_is_zero && !$y->is_int(); # non-integer power
+
+ my $y1 = $y->as_number()->{value}; # make MBI part
+
+ # if ($x == -1)
+ if ($x->{sign} eq '-' && $MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ # if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1
+ return $MBI->_is_odd($y1) ? $x : $x->babs(1);
+ }
+ if ($x_is_zero)
+ {
+ return $x if $y->{sign} eq '+'; # 0**y => 0 (if not y <= 0)
+ # 0 ** -y => 1 / (0 ** y) => 1 / 0! (1 / 0 => +inf)
+ return $x->binf();
+ }
+
+ my $new_sign = '+';
+ $new_sign = $MBI->_is_odd($y1) ? '-' : '+' if $x->{sign} ne '+';
+
+ # calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster)
+ $x->{_m} = $MBI->_pow( $x->{_m}, $y1);
+ $x->{_e} = $MBI->_mul ($x->{_e}, $y1);
+
+ $x->{sign} = $new_sign;
+ $x->bnorm();
+ if ($y->{sign} eq '-')
+ {
+ # modify $x in place!
+ my $z = $x->copy(); $x->bone();
+ return scalar $x->bdiv($z,$a,$p,$r); # round in one go (might ignore y's A!)
+ }
+ $x->round($a,$p,$r,$y);
+ }
+
+sub bmodpow
+ {
+ # takes a very large number to a very large exponent in a given very
+ # large modulus, quickly, thanks to binary exponentation. Supports
+ # negative exponents.
+ my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
+
+ return $num if $num->modify('bmodpow');
+
+ # check modulus for valid values
+ return $num->bnan() if ($mod->{sign} ne '+' # NaN, - , -inf, +inf
+ || $mod->is_zero());
+
+ # check exponent for valid values
+ if ($exp->{sign} =~ /\w/)
+ {
+ # i.e., if it's NaN, +inf, or -inf...
+ return $num->bnan();
+ }
+
+ $num->bmodinv ($mod) if ($exp->{sign} eq '-');
+
+ # check num for valid values (also NaN if there was no inverse but $exp < 0)
+ return $num->bnan() if $num->{sign} !~ /^[+-]$/;
+
+ # $mod is positive, sign on $exp is ignored, result also positive
+
+ # XXX TODO: speed it up when all three numbers are integers
+ $num->bpow($exp)->bmod($mod);
+ }
+
+###############################################################################
+# trigonometric functions
+
+# helper function for bpi() and batan2(), calculates arcus tanges (1/x)
+
+sub _atan_inv
+ {
+ # return a/b so that a/b approximates atan(1/x) to at least limit digits
+ my ($self, $x, $limit) = @_;
+
+ # Taylor: x^3 x^5 x^7 x^9
+ # atan = x - --- + --- - --- + --- - ...
+ # 3 5 7 9
+
+ # 1 1 1 1
+ # atan 1/x = - - ------- + ------- - ------- + ...
+ # x x^3 * 3 x^5 * 5 x^7 * 7
+
+ # 1 1 1 1
+ # atan 1/x = - - --------- + ---------- - ----------- + ...
+ # 5 3 * 125 5 * 3125 7 * 78125
+
+ # Subtraction/addition of a rational:
+
+ # 5 7 5*3 +- 7*4
+ # - +- - = ----------
+ # 4 3 4*3
+
+ # Term: N N+1
+ #
+ # a 1 a * d * c +- b
+ # ----- +- ------------------ = ----------------
+ # b d * c b * d * c
+
+ # since b1 = b0 * (d-2) * c
+
+ # a 1 a * d +- b / c
+ # ----- +- ------------------ = ----------------
+ # b d * c b * d
+
+ # and d = d + 2
+ # and c = c * x * x
+
+ # u = d * c
+ # stop if length($u) > limit
+ # a = a * u +- b
+ # b = b * u
+ # d = d + 2
+ # c = c * x * x
+ # sign = 1 - sign
+
+ my $a = $MBI->_one();
+ my $b = $MBI->_copy($x);
+
+ my $x2 = $MBI->_mul( $MBI->_copy($x), $b); # x2 = x * x
+ my $d = $MBI->_new( 3 ); # d = 3
+ my $c = $MBI->_mul( $MBI->_copy($x), $x2); # c = x ^ 3
+ my $two = $MBI->_new( 2 );
+
+ # run the first step unconditionally
+ my $u = $MBI->_mul( $MBI->_copy($d), $c);
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_sub($a, $b);
+ $b = $MBI->_mul($b, $u);
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+
+ # a is now a * (d-3) * c
+ # b is now b * (d-2) * c
+
+ # run the second step unconditionally
+ $u = $MBI->_mul( $MBI->_copy($d), $c);
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_add($a, $b);
+ $b = $MBI->_mul($b, $u);
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+
+ # a is now a * (d-3) * (d-5) * c * c
+ # b is now b * (d-2) * (d-4) * c * c
+
+ # so we can remove c * c from both a and b to shorten the numbers involved:
+ $a = $MBI->_div($a, $x2);
+ $b = $MBI->_div($b, $x2);
+ $a = $MBI->_div($a, $x2);
+ $b = $MBI->_div($b, $x2);
+
+# my $step = 0;
+ my $sign = 0; # 0 => -, 1 => +
+ while (3 < 5)
+ {
+# $step++;
+# if (($i++ % 100) == 0)
+# {
+# print "a=",$MBI->_str($a),"\n";
+# print "b=",$MBI->_str($b),"\n";
+# }
+# print "d=",$MBI->_str($d),"\n";
+# print "x2=",$MBI->_str($x2),"\n";
+# print "c=",$MBI->_str($c),"\n";
+
+ my $u = $MBI->_mul( $MBI->_copy($d), $c);
+ # use _alen() for libs like GMP where _len() would be O(N^2)
+ last if $MBI->_alen($u) > $limit;
+ my ($bc,$r) = $MBI->_div( $MBI->_copy($b), $c);
+ if ($MBI->_is_zero($r))
+ {
+ # b / c is an integer, so we can remove c from all terms
+ # this happens almost every time:
+ $a = $MBI->_mul($a, $d);
+ $a = $MBI->_sub($a, $bc) if $sign == 0;
+ $a = $MBI->_add($a, $bc) if $sign == 1;
+ $b = $MBI->_mul($b, $d);
+ }
+ else
+ {
+ # b / c is not an integer, so we keep c in the terms
+ # this happens very rarely, for instance for x = 5, this happens only
+ # at the following steps:
+ # 1, 5, 14, 32, 72, 157, 340, ...
+ $a = $MBI->_mul($a, $u);
+ $a = $MBI->_sub($a, $b) if $sign == 0;
+ $a = $MBI->_add($a, $b) if $sign == 1;
+ $b = $MBI->_mul($b, $u);
+ }
+ $d = $MBI->_add($d, $two);
+ $c = $MBI->_mul($c, $x2);
+ $sign = 1 - $sign;
+
+ }
+
+# print "Took $step steps for ", $MBI->_str($x),"\n";
+# print "a=",$MBI->_str($a),"\n"; print "b=",$MBI->_str($b),"\n";
+ # return a/b so that a/b approximates atan(1/x)
+ ($a,$b);
+ }
+
+sub bpi
+ {
+ my ($self,$n) = @_;
+ if (@_ == 0)
+ {
+ $self = $class;
+ }
+ if (@_ == 1)
+ {
+ # called like Math::BigFloat::bpi(10);
+ $n = $self; $self = $class;
+ # called like Math::BigFloat->bpi();
+ $n = undef if $n eq 'Math::BigFloat';
+ }
+ $self = ref($self) if ref($self);
+ my $fallback = defined $n ? 0 : 1;
+ $n = 40 if !defined $n || $n < 1;
+
+ # after 黃見利 (Hwang Chien-Lih) (1997)
+ # pi/4 = 183 * atan(1/239) + 32 * atan(1/1023) – 68 * atan(1/5832)
+ # + 12 * atan(1/110443) - 12 * atan(1/4841182) - 100 * atan(1/6826318)
+
+ # a few more to prevent rounding errors
+ $n += 4;
+
+ my ($a,$b) = $self->_atan_inv( $MBI->_new(239),$n);
+ my ($c,$d) = $self->_atan_inv( $MBI->_new(1023),$n);
+ my ($e,$f) = $self->_atan_inv( $MBI->_new(5832),$n);
+ my ($g,$h) = $self->_atan_inv( $MBI->_new(110443),$n);
+ my ($i,$j) = $self->_atan_inv( $MBI->_new(4841182),$n);
+ my ($k,$l) = $self->_atan_inv( $MBI->_new(6826318),$n);
+
+ $MBI->_mul($a, $MBI->_new(732));
+ $MBI->_mul($c, $MBI->_new(128));
+ $MBI->_mul($e, $MBI->_new(272));
+ $MBI->_mul($g, $MBI->_new(48));
+ $MBI->_mul($i, $MBI->_new(48));
+ $MBI->_mul($k, $MBI->_new(400));
+
+ my $x = $self->bone(); $x->{_m} = $a; my $x_d = $self->bone(); $x_d->{_m} = $b;
+ my $y = $self->bone(); $y->{_m} = $c; my $y_d = $self->bone(); $y_d->{_m} = $d;
+ my $z = $self->bone(); $z->{_m} = $e; my $z_d = $self->bone(); $z_d->{_m} = $f;
+ my $u = $self->bone(); $u->{_m} = $g; my $u_d = $self->bone(); $u_d->{_m} = $h;
+ my $v = $self->bone(); $v->{_m} = $i; my $v_d = $self->bone(); $v_d->{_m} = $j;
+ my $w = $self->bone(); $w->{_m} = $k; my $w_d = $self->bone(); $w_d->{_m} = $l;
+ $x->bdiv($x_d, $n);
+ $y->bdiv($y_d, $n);
+ $z->bdiv($z_d, $n);
+ $u->bdiv($u_d, $n);
+ $v->bdiv($v_d, $n);
+ $w->bdiv($w_d, $n);
+
+ delete $x->{_a}; delete $y->{_a}; delete $z->{_a};
+ delete $u->{_a}; delete $v->{_a}; delete $w->{_a};
+ $x->badd($y)->bsub($z)->badd($u)->bsub($v)->bsub($w);
+
+ $x->bround($n-4);
+ delete $x->{_a} if $fallback == 1;
+ $x;
+ }
+
+sub bcos
+ {
+ # Calculate a cosinus of x.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # Taylor: x^2 x^4 x^6 x^8
+ # cos = 1 - --- + --- - --- + --- ...
+ # 2! 4! 6! 8!
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('bcos') || $x->is_nan();
+
+ return $x->bone(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ my $sign = 1; # start with -=
+ my $below = $self->new(2); my $factorial = $self->new(3);
+ $x->bone(); delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub bsin
+ {
+ # Calculate a sinus of x.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # taylor: x^3 x^5 x^7 x^9
+ # sin = x - --- + --- - --- + --- ...
+ # 3! 5! 7! 9!
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('bsin') || $x->is_nan();
+
+ return $x->bzero(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ $over->bmul($x); # X ^ 3 as starting value
+ my $sign = 1; # start with -=
+ my $below = $self->new(6); my $factorial = $self->new(4);
+ delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ $below->bmul($factorial); $factorial->binc(); # n*(n+1)
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+sub batan2
+ {
+ # calculate arcus tangens of ($y/$x)
+
+ # set up parameters
+ my ($self,$y,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$y,$x,@r) = objectify(2,@_);
+ }
+
+ return $y if $y->modify('batan2');
+
+ return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
+
+ # Y X
+ # 0 0 result is 0
+ # 0 +x result is 0
+ # ? inf result is 0
+ return $y->bzero(@r) if ($x->is_inf('+') && !$y->is_inf()) || ($y->is_zero() && $x->{sign} eq '+');
+
+ # Y X
+ # != 0 -inf result is +- pi
+ if ($x->is_inf() || $y->is_inf())
+ {
+ # calculate PI
+ my $pi = $self->bpi(@r);
+ if ($y->is_inf())
+ {
+ # upgrade to BigRat etc.
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+ if ($x->{sign} eq '-inf')
+ {
+ # calculate 3 pi/4
+ $MBI->_mul($pi->{_m}, $MBI->_new(3));
+ $MBI->_div($pi->{_m}, $MBI->_new(4));
+ }
+ elsif ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4
+ $MBI->_div($pi->{_m}, $MBI->_new(4));
+ }
+ else
+ {
+ # calculate pi/2
+ $MBI->_div($pi->{_m}, $MBI->_new(2));
+ }
+ $y->{sign} = substr($y->{sign},0,1); # keep +/-
+ }
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ # keep the sign of $y
+ return $y;
+ }
+
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+
+ # Y X
+ # 0 -x result is PI
+ if ($y->is_zero())
+ {
+ # calculate PI
+ my $pi = $self->bpi(@r);
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ $y->{sign} = '+';
+ return $y;
+ }
+
+ # Y X
+ # +y 0 result is PI/2
+ # -y 0 result is -PI/2
+ if ($x->is_zero())
+ {
+ # calculate PI/2
+ my $pi = $self->bpi(@r);
+ # modify $y in place
+ $y->{_m} = $pi->{_m};
+ $y->{_e} = $pi->{_e};
+ $y->{_es} = $pi->{_es};
+ # -y => -PI/2, +y => PI/2
+ $MBI->_div($y->{_m}, $MBI->_new(2));
+ return $y;
+ }
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($y,@params) = $y->_find_round_parameters(@r);
+
+ # error in _find_round_parameters?
+ return $y if $y->is_nan();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($y->{_m}) && $MBI->_is_zero($y->{_e}))
+ {
+ # shortcut: 1 1 result is PI/4
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ # 1,1 => PI/4
+ my $pi_4 = $self->bpi( $scale - 3);
+ # modify $y in place
+ $y->{_m} = $pi_4->{_m};
+ $y->{_e} = $pi_4->{_e};
+ $y->{_es} = $pi_4->{_es};
+ # 1 1 => +
+ # -1 1 => -
+ # 1 -1 => -
+ # -1 -1 => +
+ $y->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+ $MBI->_div($y->{_m}, $MBI->_new(4));
+ return $y;
+ }
+ # shortcut: 1 int(X) result is _atan_inv(X)
+
+ # is integer
+ if ($x->{_es} eq '+')
+ {
+ my $x1 = $MBI->_copy($x->{_m});
+ $MBI->_lsft($x1, $x->{_e},10) unless $MBI->_is_zero($x->{_e});
+
+ my ($a,$b) = $self->_atan_inv($x1, $scale);
+ my $y_sign = $y->{sign};
+ # calculate A/B
+ $y->bone(); $y->{_m} = $a; my $y_d = $self->bone(); $y_d->{_m} = $b;
+ $y->bdiv($y_d, @r);
+ $y->{sign} = $y_sign;
+ return $y;
+ }
+ }
+
+ # handle all other cases
+ # X Y
+ # +x +y 0 to PI/2
+ # -x +y PI/2 to PI
+ # +x -y 0 to -PI/2
+ # -x -y -PI/2 to -PI
+
+ my $y_sign = $y->{sign};
+
+ # divide $x by $y
+ $y->bdiv($x, $scale) unless $x->is_one();
+ $y->batan(@r);
+
+ # restore sign
+ $y->{sign} = $y_sign;
+
+ $y;
+ }
+
+sub batan
+ {
+ # Calculate a arcus tangens of x.
+ my ($x,@r) = @_;
+ my $self = ref($x);
+
+ # taylor: x^3 x^5 x^7 x^9
+ # atan = x - --- + --- - --- + --- ...
+ # 3 5 7 9
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # constant object or error in _find_round_parameters?
+ return $x if $x->modify('batan') || $x->is_nan();
+
+ if ($x->{sign} =~ /^[+-]inf\z/)
+ {
+ # +inf result is PI/2
+ # -inf result is -PI/2
+ # calculate PI/2
+ my $pi = $self->bpi(@r);
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # -y => -PI/2, +y => PI/2
+ $x->{sign} = substr($x->{sign},0,1); # +inf => +
+ $MBI->_div($x->{_m}, $MBI->_new(2));
+ return $x;
+ }
+
+ return $x->bzero(@r) if $x->is_zero();
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # disable P
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it is not
+ # enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ # 1 or -1 => PI/4
+ # inlined is_one() && is_one('-')
+ if ($MBI->_is_one($x->{_m}) && $MBI->_is_zero($x->{_e}))
+ {
+ my $pi = $self->bpi($scale - 3);
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # leave the sign of $x alone (+1 => +PI/4, -1 => -PI/4)
+ $MBI->_div($x->{_m}, $MBI->_new(4));
+ return $x;
+ }
+
+ # This series is only valid if -1 < x < 1, so for other x we need to
+ # to calculate PI/2 - atan(1/x):
+ my $one = $MBI->_new(1);
+ my $pi = undef;
+ if ($x->{_es} eq '+' && ($MBI->_acmp($x->{_m},$one) >= 0))
+ {
+ # calculate PI/2
+ $pi = $self->bpi($scale - 3);
+ $MBI->_div($pi->{_m}, $MBI->_new(2));
+ # calculate 1/$x:
+ my $x_copy = $x->copy();
+ # modify $x in place
+ $x->bone(); $x->bdiv($x_copy,$scale);
+ }
+
+ # when user set globals, they would interfere with our calculation, so
+ # disable them and later re-enable them
+ no strict 'refs';
+ my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
+ my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
+ # we also need to disable any set A or P on $x (_find_round_parameters took
+ # them already into account), since these would interfere, too
+ delete $x->{_a}; delete $x->{_p};
+ # need to disable $upgrade in BigInt, to avoid deep recursion
+ local $Math::BigInt::upgrade = undef;
+
+ my $last = 0;
+ my $over = $x * $x; # X ^ 2
+ my $x2 = $over->copy(); # X ^ 2; difference between terms
+ $over->bmul($x); # X ^ 3 as starting value
+ my $sign = 1; # start with -=
+ my $below = $self->new(3);
+ my $two = $self->new(2);
+ delete $x->{_a}; delete $x->{_p};
+
+ my $limit = $self->new("1E-". ($scale-1));
+ #my $steps = 0;
+ while (3 < 5)
+ {
+ # we calculate the next term, and add it to the last
+ # when the next term is below our limit, it won't affect the outcome
+ # anymore, so we stop:
+ my $next = $over->copy()->bdiv($below,$scale);
+ last if $next->bacmp($limit) <= 0;
+
+ if ($sign == 0)
+ {
+ $x->badd($next);
+ }
+ else
+ {
+ $x->bsub($next);
+ }
+ $sign = 1-$sign; # alternate
+ # calculate things for the next term
+ $over->bmul($x2); # $x*$x
+ $below->badd($two); # n += 2
+ }
+
+ if (defined $pi)
+ {
+ my $x_copy = $x->copy();
+ # modify $x in place
+ $x->{_m} = $pi->{_m};
+ $x->{_e} = $pi->{_e};
+ $x->{_es} = $pi->{_es};
+ # PI/2 - $x
+ $x->bsub($x_copy);
+ }
+
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+ # restore globals
+ $$abr = $ab; $$pbr = $pb;
+ $x;
+ }
+
+###############################################################################
+# rounding functions
+
+sub bfround
+ {
+ # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
+ # $n == 0 means round to integer
+ # expects and returns normalized numbers!
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new(shift) if !ref($x);
+
+ my ($scale,$mode) = $x->_scale_p(@_);
+ return $x if !defined $scale || $x->modify('bfround'); # no-op
+
+ # never round a 0, +-inf, NaN
+ if ($x->is_zero())
+ {
+ $x->{_p} = $scale if !defined $x->{_p} || $x->{_p} < $scale; # -3 < -2
+ return $x;
+ }
+ return $x if $x->{sign} !~ /^[+-]$/;
+
+ # don't round if x already has lower precision
+ return $x if (defined $x->{_p} && $x->{_p} < 0 && $scale < $x->{_p});
+
+ $x->{_p} = $scale; # remember round in any case
+ delete $x->{_a}; # and clear A
+ if ($scale < 0)
+ {
+ # round right from the '.'
+
+ return $x if $x->{_es} eq '+'; # e >= 0 => nothing to round
+
+ $scale = -$scale; # positive for simplicity
+ my $len = $MBI->_len($x->{_m}); # length of mantissa
+
+ # the following poses a restriction on _e, but if _e is bigger than a
+ # scalar, you got other problems (memory etc) anyway
+ my $dad = -(0+ ($x->{_es}.$MBI->_num($x->{_e}))); # digits after dot
+ my $zad = 0; # zeros after dot
+ $zad = $dad - $len if (-$dad < -$len); # for 0.00..00xxx style
+
+ # p rint "scale $scale dad $dad zad $zad len $len\n";
+ # number bsstr len zad dad
+ # 0.123 123e-3 3 0 3
+ # 0.0123 123e-4 3 1 4
+ # 0.001 1e-3 1 2 3
+ # 1.23 123e-2 3 0 2
+ # 1.2345 12345e-4 5 0 4
+
+ # do not round after/right of the $dad
+ return $x if $scale > $dad; # 0.123, scale >= 3 => exit
+
+ # round to zero if rounding inside the $zad, but not for last zero like:
+ # 0.0065, scale -2, round last '0' with following '65' (scale == zad case)
+ return $x->bzero() if $scale < $zad;
+ if ($scale == $zad) # for 0.006, scale -3 and trunc
+ {
+ $scale = -$len;
+ }
+ else
+ {
+ # adjust round-point to be inside mantissa
+ if ($zad != 0)
+ {
+ $scale = $scale-$zad;
+ }
+ else
+ {
+ my $dbd = $len - $dad; $dbd = 0 if $dbd < 0; # digits before dot
+ $scale = $dbd+$scale;
+ }
+ }
+ }
+ else
+ {
+ # round left from the '.'
+
+ # 123 => 100 means length(123) = 3 - $scale (2) => 1
+
+ my $dbt = $MBI->_len($x->{_m});
+ # digits before dot
+ my $dbd = $dbt + ($x->{_es} . $MBI->_num($x->{_e}));
+ # should be the same, so treat it as this
+ $scale = 1 if $scale == 0;
+ # shortcut if already integer
+ return $x if $scale == 1 && $dbt <= $dbd;
+ # maximum digits before dot
+ ++$dbd;
+
+ if ($scale > $dbd)
+ {
+ # not enough digits before dot, so round to zero
+ return $x->bzero;
+ }
+ elsif ( $scale == $dbd )
+ {
+ # maximum
+ $scale = -$dbt;
+ }
+ else
+ {
+ $scale = $dbd - $scale;
+ }
+ }
+ # pass sign to bround for rounding modes '+inf' and '-inf'
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
+ $m->bround($scale,$mode);
+ $x->{_m} = $m->{value}; # get our mantissa back
+ $x->bnorm();
+ }
+
+sub bround
+ {
+ # accuracy: preserve $N digits, and overwrite the rest with 0's
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new(shift) if !ref($x);
+
+ if (($_[0] || 0) < 0)
+ {
+ require Carp; Carp::croak ('bround() needs positive accuracy');
+ }
+
+ my ($scale,$mode) = $x->_scale_a(@_);
+ return $x if !defined $scale || $x->modify('bround'); # no-op
+
+ # scale is now either $x->{_a}, $accuracy, or the user parameter
+ # test whether $x already has lower accuracy, do nothing in this case
+ # but do round if the accuracy is the same, since a math operation might
+ # want to round a number with A=5 to 5 digits afterwards again
+ return $x if defined $x->{_a} && $x->{_a} < $scale;
+
+ # scale < 0 makes no sense
+ # scale == 0 => keep all digits
+ # never round a +-inf, NaN
+ return $x if ($scale <= 0) || $x->{sign} !~ /^[+-]$/;
+
+ # 1: never round a 0
+ # 2: if we should keep more digits than the mantissa has, do nothing
+ if ($x->is_zero() || $MBI->_len($x->{_m}) <= $scale)
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale;
+ return $x;
+ }
+
+ # pass sign to bround for '+inf' and '-inf' rounding modes
+ my $m = bless { sign => $x->{sign}, value => $x->{_m} }, 'Math::BigInt';
+
+ $m->bround($scale,$mode); # round mantissa
+ $x->{_m} = $m->{value}; # get our mantissa back
+ $x->{_a} = $scale; # remember rounding
+ delete $x->{_p}; # and clear P
+ $x->bnorm(); # del trailing zeros gen. by bround()
+ }
+
+sub bfloor
+ {
+ # return integer less or equal then $x
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bfloor');
+
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ # if $x has digits after dot
+ if ($x->{_es} eq '-')
+ {
+ $x->{_m} = $MBI->_rsft($x->{_m},$x->{_e},10); # cut off digits after dot
+ $x->{_e} = $MBI->_zero(); # trunc/norm
+ $x->{_es} = '+'; # abs e
+ $MBI->_inc($x->{_m}) if $x->{sign} eq '-'; # increment if negative
+ }
+ $x->round($a,$p,$r);
+ }
+
+sub bceil
+ {
+ # return integer greater or equal then $x
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->modify('bceil');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ # if $x has digits after dot
+ if ($x->{_es} eq '-')
+ {
+ $x->{_m} = $MBI->_rsft($x->{_m},$x->{_e},10); # cut off digits after dot
+ $x->{_e} = $MBI->_zero(); # trunc/norm
+ $x->{_es} = '+'; # abs e
+ $MBI->_inc($x->{_m}) if $x->{sign} eq '+'; # increment if positive
+ }
+ $x->round($a,$p,$r);
+ }
+
+sub brsft
+ {
+ # shift right by $y (divide by power of $n)
+
+ # set up parameters
+ my ($self,$x,$y,$n,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('brsft');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ $n = 2 if !defined $n; $n = $self->new($n);
+
+ # negative amount?
+ return $x->blsft($y->copy()->babs(),$n) if $y->{sign} =~ /^-/;
+
+ # the following call to bdiv() will return either quo or (quo,reminder):
+ $x->bdiv($n->bpow($y),$a,$p,$r,$y);
+ }
+
+sub blsft
+ {
+ # shift left by $y (multiply by power of $n)
+
+ # set up parameters
+ my ($self,$x,$y,$n,$a,$p,$r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,$a,$p,$r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('blsft');
+ return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
+
+ $n = 2 if !defined $n; $n = $self->new($n);
+
+ # negative amount?
+ return $x->brsft($y->copy()->babs(),$n) if $y->{sign} =~ /^-/;
+
+ $x->bmul($n->bpow($y),$a,$p,$r,$y);
+ }
+
+###############################################################################
+
+sub DESTROY
+ {
+ # going through AUTOLOAD for every DESTROY is costly, avoid it by empty sub
+ }
+
+sub AUTOLOAD
+ {
+ # make fxxx and bxxx both work by selectively mapping fxxx() to MBF::bxxx()
+ # or falling back to MBI::bxxx()
+ my $name = $AUTOLOAD;
+
+ $name =~ s/(.*):://; # split package
+ my $c = $1 || $class;
+ no strict 'refs';
+ $c->import() if $IMPORT == 0;
+ if (!_method_alias($name))
+ {
+ if (!defined $name)
+ {
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("$c: Can't call a method without name");
+ }
+ if (!_method_hand_up($name))
+ {
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call $c\-\>$name, not a valid method");
+ }
+ # try one level up, but subst. bxxx() for fxxx() since MBI only got bxxx()
+ $name =~ s/^f/b/;
+ return &{"Math::BigInt"."::$name"}(@_);
+ }
+ my $bname = $name; $bname =~ s/^f/b/;
+ $c .= "::$name";
+ *{$c} = \&{$bname};
+ &{$c}; # uses @_
+ }
+
+sub exponent
+ {
+ # return a copy of the exponent
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+-]//;
+ return Math::BigInt->new($s); # -inf, +inf => +inf
+ }
+ Math::BigInt->new( $x->{_es} . $MBI->_str($x->{_e}));
+ }
+
+sub mantissa
+ {
+ # return a copy of the mantissa
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+]//;
+ return Math::BigInt->new($s); # -inf, +inf => +inf
+ }
+ my $m = Math::BigInt->new( $MBI->_str($x->{_m}));
+ $m->bneg() if $x->{sign} eq '-';
+
+ $m;
+ }
+
+sub parts
+ {
+ # return a copy of both the exponent and the mantissa
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+]//; my $se = $s; $se =~ s/^[-]//;
+ return ($self->new($s),$self->new($se)); # +inf => inf and -inf,+inf => inf
+ }
+ my $m = Math::BigInt->bzero();
+ $m->{value} = $MBI->_copy($x->{_m});
+ $m->bneg() if $x->{sign} eq '-';
+ ($m, Math::BigInt->new( $x->{_es} . $MBI->_num($x->{_e}) ));
+ }
+
+##############################################################################
+# private stuff (internal use only)
+
+sub import
+ {
+ my $self = shift;
+ my $l = scalar @_;
+ my $lib = ''; my @a;
+ my $lib_kind = 'try';
+ $IMPORT=1;
+ for ( my $i = 0; $i < $l ; $i++)
+ {
+ if ( $_[$i] eq ':constant' )
+ {
+ # This causes overlord er load to step in. 'binary' and 'integer'
+ # are handled by BigInt.
+ overload::constant float => sub { $self->new(shift); };
+ }
+ elsif ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ # alternative library
+ $lib = $_[$i+1] || ''; # default Calc
+ $lib_kind = $1; # lib, try or only
+ $i++;
+ }
+ elsif ($_[$i] eq 'with')
+ {
+ # alternative class for our private parts()
+ # XXX: no longer supported
+ # $MBI = $_[$i+1] || 'Math::BigInt';
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+
+ $lib =~ tr/a-zA-Z0-9,://cd; # restrict to sane characters
+ # let use Math::BigInt lib => 'GMP'; use Math::BigFloat; still work
+ my $mbilib = eval { Math::BigInt->config()->{lib} };
+ if ((defined $mbilib) && ($MBI eq 'Math::BigInt::Calc'))
+ {
+ # MBI already loaded
+ Math::BigInt->import( $lib_kind, "$lib,$mbilib", 'objectify');
+ }
+ else
+ {
+ # MBI not loaded, or with ne "Math::BigInt::Calc"
+ $lib .= ",$mbilib" if defined $mbilib;
+ $lib =~ s/^,//; # don't leave empty
+
+ # replacement library can handle lib statement, but also could ignore it
+
+ # Perl < 5.6.0 dies with "out of memory!" when eval() and ':constant' is
+ # used in the same script, or eval inside import(). So we require MBI:
+ require Math::BigInt;
+ Math::BigInt->import( $lib_kind => $lib, 'objectify' );
+ }
+ if ($@)
+ {
+ require Carp; Carp::croak ("Couldn't load $lib: $! $@");
+ }
+ # find out which one was actually loaded
+ $MBI = Math::BigInt->config()->{lib};
+
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( $self, sub { $MBI = $_[0]; } );
+
+ $self->export_to_level(1,$self,@a); # export wanted functions
+ }
+
+sub bnorm
+ {
+ # adjust m and e so that m is smallest possible
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $zeros = $MBI->_zeros($x->{_m}); # correct for trailing zeros
+ if ($zeros != 0)
+ {
+ my $z = $MBI->_new($zeros);
+ $x->{_m} = $MBI->_rsft ($x->{_m}, $z, 10);
+ if ($x->{_es} eq '-')
+ {
+ if ($MBI->_acmp($x->{_e},$z) >= 0)
+ {
+ $x->{_e} = $MBI->_sub ($x->{_e}, $z);
+ $x->{_es} = '+' if $MBI->_is_zero($x->{_e});
+ }
+ else
+ {
+ $x->{_e} = $MBI->_sub ( $MBI->_copy($z), $x->{_e});
+ $x->{_es} = '+';
+ }
+ }
+ else
+ {
+ $x->{_e} = $MBI->_add ($x->{_e}, $z);
+ }
+ }
+ else
+ {
+ # $x can only be 0Ey if there are no trailing zeros ('0' has 0 trailing
+ # zeros). So, for something like 0Ey, set y to 1, and -0 => +0
+ $x->{sign} = '+', $x->{_es} = '+', $x->{_e} = $MBI->_one()
+ if $MBI->_is_zero($x->{_m});
+ }
+
+ $x; # MBI bnorm is no-op, so dont call it
+ }
+
+##############################################################################
+
+sub as_hex
+ {
+ # return number as hexadecimal string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0x0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_hex();
+ }
+
+sub as_bin
+ {
+ # return number as binary digit string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0b0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_bin();
+ }
+
+sub as_oct
+ {
+ # return number as octal digit string (only for integers defined)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+ return '0' if $x->is_zero();
+
+ return $nan if $x->{_es} ne '+'; # how to do 1e-1 in hex!?
+
+ my $z = $MBI->_copy($x->{_m});
+ if (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z->as_oct();
+ }
+
+sub as_number
+ {
+ # return copy as a bigint representation of this BigFloat number
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('as_number');
+
+ if (!$x->isa('Math::BigFloat'))
+ {
+ # if the object can as_number(), use it
+ return $x->as_number() if $x->can('as_number');
+ # otherwise, get us a float and then a number
+ $x = $x->can('as_float') ? $x->as_float() : $self->new(0+"$x");
+ }
+
+ my $z = $MBI->_copy($x->{_m});
+ if ($x->{_es} eq '-') # < 0
+ {
+ $MBI->_rsft( $z, $x->{_e},10);
+ }
+ elsif (! $MBI->_is_zero($x->{_e})) # > 0
+ {
+ $MBI->_lsft( $z, $x->{_e},10);
+ }
+ $z = Math::BigInt->new( $x->{sign} . $MBI->_num($z));
+ $z;
+ }
+
+sub length
+ {
+ my $x = shift;
+ my $class = ref($x) || $x;
+ $x = $class->new(shift) unless ref($x);
+
+ return 1 if $MBI->_is_zero($x->{_m});
+
+ my $len = $MBI->_len($x->{_m});
+ $len += $MBI->_num($x->{_e}) if $x->{_es} eq '+';
+ if (wantarray())
+ {
+ my $t = 0;
+ $t = $MBI->_num($x->{_e}) if $x->{_es} eq '-';
+ return ($len, $t);
+ }
+ $len;
+ }
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigFloat - Arbitrary size floating point math package
+
+=head1 SYNOPSIS
+
+ use Math::BigFloat;
+
+ # Number creation
+ my $x = Math::BigFloat->new($str); # defaults to 0
+ my $y = $x->copy(); # make a true copy
+ my $nan = Math::BigFloat->bnan(); # create a NotANumber
+ my $zero = Math::BigFloat->bzero(); # create a +0
+ my $inf = Math::BigFloat->binf(); # create a +inf
+ my $inf = Math::BigFloat->binf('-'); # create a -inf
+ my $one = Math::BigFloat->bone(); # create a +1
+ my $mone = Math::BigFloat->bone('-'); # create a -1
+
+ my $pi = Math::BigFloat->bpi(100); # PI to 100 digits
+
+ # the following examples compute their result to 100 digits accuracy:
+ my $cos = Math::BigFloat->new(1)->bcos(100); # cosinus(1)
+ my $sin = Math::BigFloat->new(1)->bsin(100); # sinus(1)
+ my $atan = Math::BigFloat->new(1)->batan(100); # arcus tangens(1)
+
+ my $atan2 = Math::BigFloat->new( 1 )->batan2( 1 ,100); # batan(1)
+ my $atan2 = Math::BigFloat->new( 1 )->batan2( 8 ,100); # batan(1/8)
+ my $atan2 = Math::BigFloat->new( -2 )->batan2( 1 ,100); # batan(-2)
+
+ # Testing
+ $x->is_zero(); # true if arg is +0
+ $x->is_nan(); # true if arg is NaN
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_pos(); # true if >= 0
+ $x->is_neg(); # true if < 0
+ $x->is_inf(sign); # true if +inf, or -inf (default is '+')
+
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+ $x->digit($n); # return the nth digit, counting from right
+ $x->digit(-$n); # return the nth digit, counting from left
+
+ # The following all modify their first argument. If you want to preserve
+ # $x, use $z = $x->copy()->bXXX($y); See under L<CAVEATS> for why this is
+ # necessary when mixing $a = $b assignments with non-overloaded math.
+
+ # set
+ $x->bzero(); # set $i to 0
+ $x->bnan(); # set $i to NaN
+ $x->bone(); # set $x to +1
+ $x->bone('-'); # set $x to -1
+ $x->binf(); # set $x to inf
+ $x->binf('-'); # set $x to -inf
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment x by 1
+ $x->bdec(); # decrement x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmod($y); # modulus ($x % $y)
+ $x->bpow($y); # power of arguments ($x ** $y)
+ $x->bmodpow($exp,$mod); # modular exponentation (($num**$exp) % $mod))
+ $x->blsft($y, $n); # left shift by $y places in base $n
+ $x->brsft($y, $n); # right shift by $y places in base $n
+ # returns (quo,rem) or quo if in scalar context
+
+ $x->blog(); # logarithm of $x to base e (Euler's number)
+ $x->blog($base); # logarithm of $x to base $base (f.i. 2)
+ $x->bexp(); # calculate e ** $x where e is Euler's number
+
+ $x->band($y); # bit-wise and
+ $x->bior($y); # bit-wise inclusive or
+ $x->bxor($y); # bit-wise exclusive or
+ $x->bnot(); # bit-wise not (two's complement)
+
+ $x->bsqrt(); # calculate square-root
+ $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root)
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+ $x->bround($N); # accuracy: preserve $N digits
+ $x->bfround($N); # precision: round to the $Nth digit
+
+ $x->bfloor(); # return integer less or equal than $x
+ $x->bceil(); # return integer greater or equal than $x
+
+ # The following do not modify their arguments:
+
+ bgcd(@values); # greatest common divisor
+ blcm(@values); # lowest common multiplicator
+
+ $x->bstr(); # return string
+ $x->bsstr(); # return string in scientific notation
+
+ $x->as_int(); # return $x as BigInt
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+
+ $x->length(); # number of digits (w/o sign and '.')
+ ($l,$f) = $x->length(); # number of digits, and length of fraction
+
+ $x->precision(); # return P of $x (or global, if P of $x undef)
+ $x->precision($n); # set P of $x to $n
+ $x->accuracy(); # return A of $x (or global, if A of $x undef)
+ $x->accuracy($n); # set A $x to $n
+
+ # these get/set the appropriate global value for all BigFloat objects
+ Math::BigFloat->precision(); # Precision
+ Math::BigFloat->accuracy(); # Accuracy
+ Math::BigFloat->round_mode(); # rounding mode
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded if you
+declare your big floating point numbers as
+
+ $i = new Math::BigFloat '12_3.456_789_123_456_789E-2';
+
+Operations with overloaded operators preserve the arguments, which is
+exactly what you expect.
+
+=head2 Canonical notation
+
+Input to these routines are either BigFloat objects, or strings of the
+following four forms:
+
+=over 2
+
+=item *
+
+C</^[+-]\d+$/>
+
+=item *
+
+C</^[+-]\d+\.\d*$/>
+
+=item *
+
+C</^[+-]\d+E[+-]?\d+$/>
+
+=item *
+
+C</^[+-]\d*\.\d+E[+-]?\d+$/>
+
+=back
+
+all with optional leading and trailing zeros and/or spaces. Additionally,
+numbers are allowed to have an underscore between any two digits.
+
+Empty strings as well as other illegal numbers results in 'NaN'.
+
+bnorm() on a BigFloat object is now effectively a no-op, since the numbers
+are always stored in normalized form. On a string, it creates a BigFloat
+object.
+
+=head2 Output
+
+Output values are BigFloat objects (normalized), except for bstr() and bsstr().
+
+The string output will always have leading and trailing zeros stripped and drop
+a plus sign. C<bstr()> will give you always the form with a decimal point,
+while C<bsstr()> (s for scientific) gives you the scientific notation.
+
+ Input bstr() bsstr()
+ '-0' '0' '0E1'
+ ' -123 123 123' '-123123123' '-123123123E0'
+ '00.0123' '0.0123' '123E-4'
+ '123.45E-2' '1.2345' '12345E-4'
+ '10E+3' '10000' '1E4'
+
+Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
+C<is_nan()>) return true or false, while others (C<bcmp()>, C<bacmp()>)
+return either undef, <0, 0 or >0 and are suited for sort.
+
+Actual math is done by using the class defined with C<with => Class;> (which
+defaults to BigInts) to represent the mantissa and exponent.
+
+The sign C</^[+-]$/> is stored separately. The string 'NaN' is used to
+represent the result when input arguments are not numbers, as well as
+the result of dividing by zero.
+
+=head2 C<mantissa()>, C<exponent()> and C<parts()>
+
+C<mantissa()> and C<exponent()> return the said parts of the BigFloat
+as BigInts such that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+C<< ($m,$e) = $x->parts(); >> is just a shortcut giving you both of them.
+
+A zero is represented and returned as C<0E1>, B<not> C<0E0> (after Knuth).
+
+Currently the mantissa is reduced as much as possible, favouring higher
+exponents over lower ones (e.g. returning 1e7 instead of 10e6 or 10000000e0).
+This might change in the future, so do not depend on it.
+
+=head2 Accuracy vs. Precision
+
+See also: L<Rounding|Rounding>.
+
+Math::BigFloat supports both precision (rounding to a certain place before or
+after the dot) and accuracy (rounding to a certain number of digits). For a
+full documentation, examples and tips on these topics please see the large
+section about rounding in L<Math::BigInt>.
+
+Since things like C<sqrt(2)> or C<1 / 3> must presented with a limited
+accuracy lest a operation consumes all resources, each operation produces
+no more than the requested number of digits.
+
+If there is no gloabl precision or accuracy set, B<and> the operation in
+question was not called with a requested precision or accuracy, B<and> the
+input $x has no accuracy or precision set, then a fallback parameter will
+be used. For historical reasons, it is called C<div_scale> and can be accessed
+via:
+
+ $d = Math::BigFloat->div_scale(); # query
+ Math::BigFloat->div_scale($n); # set to $n digits
+
+The default value for C<div_scale> is 40.
+
+In case the result of one operation has more digits than specified,
+it is rounded. The rounding mode taken is either the default mode, or the one
+supplied to the operation after the I<scale>:
+
+ $x = Math::BigFloat->new(2);
+ Math::BigFloat->accuracy(5); # 5 digits max
+ $y = $x->copy()->bdiv(3); # will give 0.66667
+ $y = $x->copy()->bdiv(3,6); # will give 0.666667
+ $y = $x->copy()->bdiv(3,6,undef,'odd'); # will give 0.666667
+ Math::BigFloat->round_mode('zero');
+ $y = $x->copy()->bdiv(3,6); # will also give 0.666667
+
+Note that C<< Math::BigFloat->accuracy() >> and C<< Math::BigFloat->precision() >>
+set the global variables, and thus B<any> newly created number will be subject
+to the global rounding B<immediately>. This means that in the examples above, the
+C<3> as argument to C<bdiv()> will also get an accuracy of B<5>.
+
+It is less confusing to either calculate the result fully, and afterwards
+round it explicitly, or use the additional parameters to the math
+functions like so:
+
+ use Math::BigFloat;
+ $x = Math::BigFloat->new(2);
+ $y = $x->copy()->bdiv(3);
+ print $y->bround(5),"\n"; # will give 0.66667
+
+ or
+
+ use Math::BigFloat;
+ $x = Math::BigFloat->new(2);
+ $y = $x->copy()->bdiv(3,5); # will give 0.66667
+ print "$y\n";
+
+=head2 Rounding
+
+=over 2
+
+=item ffround ( +$scale )
+
+Rounds to the $scale'th place left from the '.', counting from the dot.
+The first digit is numbered 1.
+
+=item ffround ( -$scale )
+
+Rounds to the $scale'th place right from the '.', counting from the dot.
+
+=item ffround ( 0 )
+
+Rounds to an integer.
+
+=item fround ( +$scale )
+
+Preserves accuracy to $scale digits from the left (aka significant digits)
+and pads the rest with zeros. If the number is between 1 and -1, the
+significant digits count from the first non-zero after the '.'
+
+=item fround ( -$scale ) and fround ( 0 )
+
+These are effectively no-ops.
+
+=back
+
+All rounding functions take as a second parameter a rounding mode from one of
+the following: 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'.
+
+The default rounding mode is 'even'. By using
+C<< Math::BigFloat->round_mode($round_mode); >> you can get and set the default
+mode for subsequent rounding. The usage of C<$Math::BigFloat::$round_mode> is
+no longer supported.
+The second parameter to the round functions then overrides the default
+temporarily.
+
+The C<as_number()> function returns a BigInt from a Math::BigFloat. It uses
+'trunc' as rounding mode to make it equivalent to:
+
+ $x = 2.5;
+ $y = int($x) + 2;
+
+You can override this by passing the desired rounding mode as parameter to
+C<as_number()>:
+
+ $x = Math::BigFloat->new(2.5);
+ $y = $x->as_number('odd'); # $y = 3
+
+=head1 METHODS
+
+Math::BigFloat supports all methods that Math::BigInt supports, except it
+calculates non-integer results when possible. Please see L<Math::BigInt>
+for a full description of each method. Below are just the most important
+differences:
+
+=head2 accuracy
+
+ $x->accuracy(5); # local for $x
+ CLASS->accuracy(5); # global for all members of CLASS
+ # Note: This also applies to new()!
+
+ $A = $x->accuracy(); # read out accuracy that affects $x
+ $A = CLASS->accuracy(); # read out global accuracy
+
+Set or get the global or local accuracy, aka how many significant digits the
+results have. If you set a global accuracy, then this also applies to new()!
+
+Warning! The accuracy I<sticks>, e.g. once you created a number under the
+influence of C<< CLASS->accuracy($A) >>, all results from math operations with
+that number will also be rounded.
+
+In most cases, you should probably round the results explicitly using one of
+L<round()>, L<bround()> or L<bfround()> or by passing the desired accuracy
+to the math operation as additional parameter:
+
+ my $x = Math::BigInt->new(30000);
+ my $y = Math::BigInt->new(7);
+ print scalar $x->copy()->bdiv($y, 2); # print 4300
+ print scalar $x->copy()->bdiv($y)->bround(2); # print 4300
+
+=head2 precision()
+
+ $x->precision(-2); # local for $x, round at the second digit right of the dot
+ $x->precision(2); # ditto, round at the second digit left of the dot
+
+ CLASS->precision(5); # Global for all members of CLASS
+ # This also applies to new()!
+ CLASS->precision(-5); # ditto
+
+ $P = CLASS->precision(); # read out global precision
+ $P = $x->precision(); # read out precision that affects $x
+
+Note: You probably want to use L<accuracy()> instead. With L<accuracy> you
+set the number of digits each result should have, with L<precision> you
+set the place where to round!
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates the expression C<e ** $x> where C<e> is Euler's number.
+
+This method was added in v1.82 of Math::BigInt (April 2007).
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v1.84 of Math::BigInt (April 2007).
+
+=head2 bpi()
+
+ print Math::BigFloat->bpi(100), "\n";
+
+Calculate PI to N digits (including the 3 before the dot). The result is
+rounded according to the current rounding mode, which defaults to "even".
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bcos()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->bcos(100), "\n";
+
+Calculate the cosinus of $x, modifying $x in place.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bsin()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->bsin(100), "\n";
+
+Calculate the sinus of $x, modifying $x in place.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan2()
+
+ my $y = Math::BigFloat->new(2);
+ my $x = Math::BigFloat->new(3);
+ print $y->batan2($x), "\n";
+
+Calculate the arcus tanges of C<$y> divided by C<$x>, modifying $y in place.
+See also L<batan()>.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan()
+
+ my $x = Math::BigFloat->new(1);
+ print $x->batan(100), "\n";
+
+Calculate the arcus tanges of $x, modifying $x in place. See also L<batan2()>.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bmuladd()
+
+ $x->bmuladd($y,$z);
+
+Multiply $x by $y, and then add $z to the result.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head1 Autocreating constants
+
+After C<use Math::BigFloat ':constant'> all the floating point constants
+in the given scope are converted to C<Math::BigFloat>. This conversion
+happens at compile time.
+
+In particular
+
+ perl -MMath::BigFloat=:constant -e 'print 2E-100,"\n"'
+
+prints the value of C<2E-100>. Note that without conversion of
+constants the expression 2E-100 will be calculated as normal floating point
+number.
+
+Please note that ':constant' does not affect integer constants, nor binary
+nor hexadecimal constants. Use L<bignum> or L<Math::BigInt> to get this to
+work.
+
+=head2 Math library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use Math::BigFloat lib => 'Calc';
+
+You can change this by using:
+
+ use Math::BigFloat lib => 'GMP';
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+Note: The keyword 'lib' will warn when the requested library could not be
+loaded. To suppress the warning use 'try' instead:
+
+ use Math::BigFloat try => 'GMP';
+
+If your script works with huge numbers and Calc is too slow for them,
+you can also for the loading of one of these libraries and if none
+of them can be used, the code will die:
+
+ use Math::BigFloat only => 'GMP,Pari';
+
+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 Math::BigFloat lib => 'Foo,Math::BigInt::Bar';
+
+See the respective low-level library documentation for further details.
+
+Please note that Math::BigFloat does B<not> use the denoted library itself,
+but it merely passes the lib argument to Math::BigInt. So, instead of the need
+to do:
+
+ use Math::BigInt lib => 'GMP';
+ use Math::BigFloat;
+
+you can roll it all into one line:
+
+ use Math::BigFloat lib => 'GMP';
+
+It is also possible to just require Math::BigFloat:
+
+ require Math::BigFloat;
+
+This will load the necessary things (like BigInt) when they are needed, and
+automatically.
+
+See L<Math::BigInt> for more details than you ever wanted to know about using
+a different low-level library.
+
+=head2 Using Math::BigInt::Lite
+
+For backwards compatibility reasons it is still possible to
+request a different storage class for use with Math::BigFloat:
+
+ use Math::BigFloat with => 'Math::BigInt::Lite';
+
+However, this request is ignored, as the current code now uses the low-level
+math libary for directly storing the number parts.
+
+=head1 EXPORTS
+
+C<Math::BigFloat> exports nothing by default, but can export the C<bpi()> method:
+
+ use Math::BigFloat qw/bpi/;
+
+ print bpi(10), "\n";
+
+=head1 BUGS
+
+Please see the file BUGS in the CPAN distribution Math::BigInt for known bugs.
+
+=head1 CAVEATS
+
+Do not try to be clever to insert some operations in between switching
+libraries:
+
+ require Math::BigFloat;
+ my $matter = Math::BigFloat->bone() + 4; # load BigInt and Calc
+ Math::BigFloat->import( lib => 'Pari' ); # load Pari, too
+ my $anti_matter = Math::BigFloat->bone()+4; # now use Pari
+
+This will create objects with numbers stored in two different backend libraries,
+and B<VERY BAD THINGS> will happen when you use these together:
+
+ my $flash_and_bang = $matter + $anti_matter; # Don't do this!
+
+=over 1
+
+=item stringify, bstr()
+
+Both stringify and bstr() now drop the leading '+'. The old code would return
+'+1.23', the new returns '1.23'. See the documentation in L<Math::BigInt> for
+reasoning and details.
+
+=item bdiv
+
+The following will probably not print what you expect:
+
+ print $c->bdiv(123.456),"\n";
+
+It prints both quotient and reminder since print works in list context. Also,
+bdiv() will modify $c, so be careful. You probably want to use
+
+ print $c / 123.456,"\n";
+ print scalar $c->bdiv(123.456),"\n"; # or if you want to modify $c
+
+instead.
+
+=item brsft
+
+The following will probably not print what you expect:
+
+ my $c = Math::BigFloat->new('3.14159');
+ print $c->brsft(3,10),"\n"; # prints 0.00314153.1415
+
+It prints both quotient and remainder, since print calls C<brsft()> in list
+context. Also, C<< $c->brsft() >> will modify $c, so be careful.
+You probably want to use
+
+ print scalar $c->copy()->brsft(3,10),"\n";
+ # or if you really want to modify $c
+ print scalar $c->brsft(3,10),"\n";
+
+instead.
+
+=item Modifying and =
+
+Beware of:
+
+ $x = Math::BigFloat->new(5);
+ $y = $x;
+
+It will not do what you think, e.g. making a copy of $x. Instead it just makes
+a second reference to the B<same> object and stores it in $y. Thus anything
+that modifies $x will modify $y (except overloaded math operators), and vice
+versa. See L<Math::BigInt> for details and how to avoid that.
+
+=item bpow
+
+C<bpow()> now modifies the first argument, unlike the old code which left
+it alone and only returned the result. This is to be consistent with
+C<badd()> etc. The first will modify $x, the second one won't:
+
+ print bpow($x,$i),"\n"; # modify $x
+ print $x->bpow($i),"\n"; # ditto
+ print $x ** $i,"\n"; # leave $x alone
+
+=item precision() vs. accuracy()
+
+A common pitfall is to use L<precision()> when you want to round a result to
+a certain number of digits:
+
+ use Math::BigFloat;
+
+ Math::BigFloat->precision(4); # does not do what you think it does
+ my $x = Math::BigFloat->new(12345); # rounds $x to "12000"!
+ print "$x\n"; # print "12000"
+ my $y = Math::BigFloat->new(3); # rounds $y to "0"!
+ print "$y\n"; # print "0"
+ $z = $x / $y; # 12000 / 0 => NaN!
+ print "$z\n";
+ print $z->precision(),"\n"; # 4
+
+Replacing L<precision> with L<accuracy> is probably not what you want, either:
+
+ use Math::BigFloat;
+
+ Math::BigFloat->accuracy(4); # enables global rounding:
+ my $x = Math::BigFloat->new(123456); # rounded immediately to "12350"
+ print "$x\n"; # print "123500"
+ my $y = Math::BigFloat->new(3); # rounded to "3
+ print "$y\n"; # print "3"
+ print $z = $x->copy()->bdiv($y),"\n"; # 41170
+ print $z->accuracy(),"\n"; # 4
+
+What you want to use instead is:
+
+ use Math::BigFloat;
+
+ my $x = Math::BigFloat->new(123456); # no rounding
+ print "$x\n"; # print "123456"
+ my $y = Math::BigFloat->new(3); # no rounding
+ print "$y\n"; # print "3"
+ print $z = $x->copy()->bdiv($y,4),"\n"; # 41150
+ print $z->accuracy(),"\n"; # undef
+
+In addition to computing what you expected, the last example also does B<not>
+"taint" the result with an accuracy or precision setting, which would
+influence any further operation.
+
+=back
+
+=head1 SEE ALSO
+
+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>.
+
+The pragmas L<bignum>, L<bigint> and L<bigrat> might also be of interest
+because they solve the autoupgrading/downgrading issue, at least partly.
+
+The package at L<http://search.cpan.org/~tels/Math-BigInt> contains
+more documentation including a full version history, testcases, empty
+subclass files and benchmarks.
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Mark Biggar, overloaded interface by Ilya Zakharevich.
+Completely rewritten by Tels L<http://bloodgate.com> in 2001 - 2006, and still
+at it in 2007.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm b/Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm
new file mode 100644
index 00000000000..871b2a969e8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm
@@ -0,0 +1,58 @@
+#!/usr/bin/perl -w
+
+package Math::BigFloat::Trace;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigFloat;
+use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
+ $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigFloat);
+
+$VERSION = 0.01;
+
+use overload; # inherit overload from BigFloat
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $value = shift;
+ my $a = $accuracy; $a = $_[0] if defined $_[0];
+ my $p = $precision; $p = $_[1] if defined $_[1];
+ my $self = Math::BigFloat->new($value,$a,$p,$round_mode);
+
+# remember, downgrading may return a BigInt, so don't meddle with class
+# bless $self,$class;
+
+ print "MBF new '$value' => '$self' (",ref($self),")";
+ return $self;
+}
+
+sub import
+ {
+ print "MBF import ",join(' ',@_);
+ my $self = shift;
+
+ # we catch the constants, the rest goes go BigFloat
+ my @a = ();
+ foreach (@_)
+ {
+ push @a, $_ if $_ ne ':constant';
+ }
+ overload::constant float => sub { $self->new(shift); };
+
+ Math::BigFloat->import(@a); # need it for subclasses
+# $self->export_to_level(1,$self,@_); # need this ?
+ }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt.pm b/Master/tlpkg/tlperl/lib/Math/BigInt.pm
new file mode 100644
index 00000000000..f97e4380798
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigInt.pm
@@ -0,0 +1,5115 @@
+package Math::BigInt;
+
+#
+# "Mike had an infinite amount to do and a negative amount of time in which
+# to do it." - Before and After
+#
+
+# The following hash values are used:
+# value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
+# sign : +,-,NaN,+inf,-inf
+# _a : accuracy
+# _p : precision
+# _f : flags, used by MBF to flag parts of a float as untouchable
+
+# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
+# underlying lib might change the reference!
+
+my $class = "Math::BigInt";
+use 5.006;
+
+$VERSION = '1.89_01';
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(objectify bgcd blcm);
+
+# _trap_inf and _trap_nan are internal and should never be accessed from the
+# outside
+use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode
+ $upgrade $downgrade $_trap_nan $_trap_inf/;
+use strict;
+
+# Inside overload, the first arg is always an object. If the original code had
+# it reversed (like $x = 2 * $y), then the third paramater is true.
+# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
+# no difference, but in some cases it does.
+
+# For overloaded ops with only one argument we simple use $_[0]->copy() to
+# preserve the argument.
+
+# Thus inheritance of overload operators becomes possible and transparent for
+# our subclasses without the need to repeat the entire overload section there.
+
+use overload
+'=' => sub { $_[0]->copy(); },
+
+# some shortcuts for speed (assumes that reversed order of arguments is routed
+# to normal '+' and we thus can always modify first arg. If this is changed,
+# this breaks and must be adjusted.)
+'+=' => sub { $_[0]->badd($_[1]); },
+'-=' => sub { $_[0]->bsub($_[1]); },
+'*=' => sub { $_[0]->bmul($_[1]); },
+'/=' => sub { scalar $_[0]->bdiv($_[1]); },
+'%=' => sub { $_[0]->bmod($_[1]); },
+'^=' => sub { $_[0]->bxor($_[1]); },
+'&=' => sub { $_[0]->band($_[1]); },
+'|=' => sub { $_[0]->bior($_[1]); },
+
+'**=' => sub { $_[0]->bpow($_[1]); },
+'<<=' => sub { $_[0]->blsft($_[1]); },
+'>>=' => sub { $_[0]->brsft($_[1]); },
+
+# not supported by Perl yet
+'..' => \&_pointpoint,
+
+'<=>' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ $_[0]->bcmp($_[1]);
+ $rc = 1 unless defined $rc;
+ $rc <=> 0;
+ },
+# we need '>=' to get things like "1 >= NaN" right:
+'>=' => sub { my $rc = $_[2] ?
+ ref($_[0])->bcmp($_[1],$_[0]) :
+ $_[0]->bcmp($_[1]);
+ # if there was a NaN involved, return false
+ return '' unless defined $rc;
+ $rc >= 0;
+ },
+'cmp' => sub {
+ $_[2] ?
+ "$_[1]" cmp $_[0]->bstr() :
+ $_[0]->bstr() cmp "$_[1]" },
+
+'cos' => sub { $_[0]->copy->bcos(); },
+'sin' => sub { $_[0]->copy->bsin(); },
+'atan2' => sub { $_[2] ?
+ ref($_[0])->new($_[1])->batan2($_[0]) :
+ $_[0]->copy()->batan2($_[1]) },
+
+# are not yet overloadable
+#'hex' => sub { print "hex"; $_[0]; },
+#'oct' => sub { print "oct"; $_[0]; },
+
+# log(N) is log(N, e), where e is Euler's number
+'log' => sub { $_[0]->copy()->blog($_[1], undef); },
+'exp' => sub { $_[0]->copy()->bexp($_[1]); },
+'int' => sub { $_[0]->copy(); },
+'neg' => sub { $_[0]->copy()->bneg(); },
+'abs' => sub { $_[0]->copy()->babs(); },
+'sqrt' => sub { $_[0]->copy()->bsqrt(); },
+'~' => sub { $_[0]->copy()->bnot(); },
+
+# for subtract it's a bit tricky to not modify b: b-a => -a+b
+'-' => sub { my $c = $_[0]->copy; $_[2] ?
+ $c->bneg()->badd( $_[1]) :
+ $c->bsub( $_[1]) },
+'+' => sub { $_[0]->copy()->badd($_[1]); },
+'*' => sub { $_[0]->copy()->bmul($_[1]); },
+
+'/' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]);
+ },
+'%' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]);
+ },
+'**' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]);
+ },
+'<<' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]);
+ },
+'>>' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]);
+ },
+'&' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]);
+ },
+'|' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]);
+ },
+'^' => sub {
+ $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]);
+ },
+
+# can modify arg of ++ and --, so avoid a copy() for speed, but don't
+# use $_[0]->bone(), it would modify $_[0] to be 1!
+'++' => sub { $_[0]->binc() },
+'--' => sub { $_[0]->bdec() },
+
+# if overloaded, O(1) instead of O(N) and twice as fast for small numbers
+'bool' => sub {
+ # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
+ # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef; :-(
+ my $t = undef;
+ $t = 1 if !$_[0]->is_zero();
+ $t;
+ },
+
+# the original qw() does not work with the TIESCALAR below, why?
+# Order of arguments unsignificant
+'""' => sub { $_[0]->bstr(); },
+'0+' => sub { $_[0]->numify(); }
+;
+
+##############################################################################
+# global constants, flags and accessory
+
+# These vars are public, but their direct usage is not recommended, use the
+# accessor methods instead
+
+$round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+$accuracy = undef;
+$precision = undef;
+$div_scale = 40;
+
+$upgrade = undef; # default is no upgrade
+$downgrade = undef; # default is no downgrade
+
+# These are internally, and not to be used from the outside at all
+
+$_trap_nan = 0; # are NaNs ok? set w/ config()
+$_trap_inf = 0; # are infs ok? set w/ config()
+my $nan = 'NaN'; # constants for easier life
+
+my $CALC = 'Math::BigInt::FastCalc'; # module to do the low level math
+ # default is FastCalc.pm
+my $IMPORT = 0; # was import() called yet?
+ # used to make require work
+my %WARN; # warn only once for low-level libs
+my %CAN; # cache for $CALC->can(...)
+my %CALLBACKS; # callbacks to notify on lib loads
+my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math
+
+##############################################################################
+# the old code had $rnd_mode, so we need to support it, too
+
+$rnd_mode = 'even';
+sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
+sub FETCH { return $round_mode; }
+sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
+
+BEGIN
+ {
+ # tie to enable $rnd_mode to work transparently
+ tie $rnd_mode, 'Math::BigInt';
+
+ # set up some handy alias names
+ *as_int = \&as_number;
+ *is_pos = \&is_positive;
+ *is_neg = \&is_negative;
+ }
+
+##############################################################################
+
+sub round_mode
+ {
+ no strict 'refs';
+ # make Class->round_mode() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ if (defined $_[0])
+ {
+ my $m = shift;
+ if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$m'");
+ }
+ return ${"${class}::round_mode"} = $m;
+ }
+ ${"${class}::round_mode"};
+ }
+
+sub upgrade
+ {
+ no strict 'refs';
+ # make Class->upgrade() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ # need to set new value?
+ if (@_ > 0)
+ {
+ return ${"${class}::upgrade"} = $_[0];
+ }
+ ${"${class}::upgrade"};
+ }
+
+sub downgrade
+ {
+ no strict 'refs';
+ # make Class->downgrade() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ # need to set new value?
+ if (@_ > 0)
+ {
+ return ${"${class}::downgrade"} = $_[0];
+ }
+ ${"${class}::downgrade"};
+ }
+
+sub div_scale
+ {
+ no strict 'refs';
+ # make Class->div_scale() work
+ my $self = shift;
+ my $class = ref($self) || $self || __PACKAGE__;
+ if (defined $_[0])
+ {
+ if ($_[0] < 0)
+ {
+ require Carp; Carp::croak ('div_scale must be greater than zero');
+ }
+ ${"${class}::div_scale"} = $_[0];
+ }
+ ${"${class}::div_scale"};
+ }
+
+sub accuracy
+ {
+ # $x->accuracy($a); ref($x) $a
+ # $x->accuracy(); ref($x)
+ # Class->accuracy(); class
+ # Class->accuracy($a); class $a
+
+ my $x = shift;
+ my $class = ref($x) || $x || __PACKAGE__;
+
+ no strict 'refs';
+ # need to set new value?
+ if (@_ > 0)
+ {
+ my $a = shift;
+ # convert objects to scalars to avoid deep recursion. If object doesn't
+ # have numify(), then hopefully it will have overloading for int() and
+ # boolean test without wandering into a deep recursion path...
+ $a = $a->numify() if ref($a) && $a->can('numify');
+
+ if (defined $a)
+ {
+ # also croak on non-numerical
+ if (!$a || $a <= 0)
+ {
+ require Carp;
+ Carp::croak ('Argument to accuracy must be greater than zero');
+ }
+ if (int($a) != $a)
+ {
+ require Carp;
+ Carp::croak ('Argument to accuracy must be an integer');
+ }
+ }
+ if (ref($x))
+ {
+ # $object->accuracy() or fallback to global
+ $x->bround($a) if $a; # not for undef, 0
+ $x->{_a} = $a; # set/overwrite, even if not rounded
+ delete $x->{_p}; # clear P
+ $a = ${"${class}::accuracy"} unless defined $a; # proper return value
+ }
+ else
+ {
+ ${"${class}::accuracy"} = $a; # set global A
+ ${"${class}::precision"} = undef; # clear global P
+ }
+ return $a; # shortcut
+ }
+
+ my $a;
+ # $object->accuracy() or fallback to global
+ $a = $x->{_a} if ref($x);
+ # but don't return global undef, when $x's accuracy is 0!
+ $a = ${"${class}::accuracy"} if !defined $a;
+ $a;
+ }
+
+sub precision
+ {
+ # $x->precision($p); ref($x) $p
+ # $x->precision(); ref($x)
+ # Class->precision(); class
+ # Class->precision($p); class $p
+
+ my $x = shift;
+ my $class = ref($x) || $x || __PACKAGE__;
+
+ no strict 'refs';
+ if (@_ > 0)
+ {
+ my $p = shift;
+ # convert objects to scalars to avoid deep recursion. If object doesn't
+ # have numify(), then hopefully it will have overloading for int() and
+ # boolean test without wandering into a deep recursion path...
+ $p = $p->numify() if ref($p) && $p->can('numify');
+ if ((defined $p) && (int($p) != $p))
+ {
+ require Carp; Carp::croak ('Argument to precision must be an integer');
+ }
+ if (ref($x))
+ {
+ # $object->precision() or fallback to global
+ $x->bfround($p) if $p; # not for undef, 0
+ $x->{_p} = $p; # set/overwrite, even if not rounded
+ delete $x->{_a}; # clear A
+ $p = ${"${class}::precision"} unless defined $p; # proper return value
+ }
+ else
+ {
+ ${"${class}::precision"} = $p; # set global P
+ ${"${class}::accuracy"} = undef; # clear global A
+ }
+ return $p; # shortcut
+ }
+
+ my $p;
+ # $object->precision() or fallback to global
+ $p = $x->{_p} if ref($x);
+ # but don't return global undef, when $x's precision is 0!
+ $p = ${"${class}::precision"} if !defined $p;
+ $p;
+ }
+
+sub config
+ {
+ # return (or set) configuration data as hash ref
+ my $class = shift || 'Math::BigInt';
+
+ no strict 'refs';
+ if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH')))
+ {
+ # try to set given options as arguments from hash
+
+ my $args = $_[0];
+ if (ref($args) ne 'HASH')
+ {
+ $args = { @_ };
+ }
+ # these values can be "set"
+ my $set_args = {};
+ foreach my $key (
+ qw/trap_inf trap_nan
+ upgrade downgrade precision accuracy round_mode div_scale/
+ )
+ {
+ $set_args->{$key} = $args->{$key} if exists $args->{$key};
+ delete $args->{$key};
+ }
+ if (keys %$args > 0)
+ {
+ require Carp;
+ Carp::croak ("Illegal key(s) '",
+ join("','",keys %$args),"' passed to $class\->config()");
+ }
+ foreach my $key (keys %$set_args)
+ {
+ if ($key =~ /^trap_(inf|nan)\z/)
+ {
+ ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
+ next;
+ }
+ # use a call instead of just setting the $variable to check argument
+ $class->$key($set_args->{$key});
+ }
+ }
+
+ # now return actual configuration
+
+ my $cfg = {
+ lib => $CALC,
+ lib_version => ${"${CALC}::VERSION"},
+ class => $class,
+ trap_nan => ${"${class}::_trap_nan"},
+ trap_inf => ${"${class}::_trap_inf"},
+ version => ${"${class}::VERSION"},
+ };
+ foreach my $key (qw/
+ upgrade downgrade precision accuracy round_mode div_scale
+ /)
+ {
+ $cfg->{$key} = ${"${class}::$key"};
+ };
+ if (@_ == 1 && (ref($_[0]) ne 'HASH'))
+ {
+ # calls of the style config('lib') return just this value
+ return $cfg->{$_[0]};
+ }
+ $cfg;
+ }
+
+sub _scale_a
+ {
+ # select accuracy parameter based on precedence,
+ # used by bround() and bfround(), may return undef for scale (means no op)
+ my ($x,$scale,$mode) = @_;
+
+ $scale = $x->{_a} unless defined $scale;
+
+ no strict 'refs';
+ my $class = ref($x);
+
+ $scale = ${ $class . '::accuracy' } unless defined $scale;
+ $mode = ${ $class . '::round_mode' } unless defined $mode;
+
+ if (defined $scale)
+ {
+ $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+ $scale = int($scale);
+ }
+
+ ($scale,$mode);
+ }
+
+sub _scale_p
+ {
+ # select precision parameter based on precedence,
+ # used by bround() and bfround(), may return undef for scale (means no op)
+ my ($x,$scale,$mode) = @_;
+
+ $scale = $x->{_p} unless defined $scale;
+
+ no strict 'refs';
+ my $class = ref($x);
+
+ $scale = ${ $class . '::precision' } unless defined $scale;
+ $mode = ${ $class . '::round_mode' } unless defined $mode;
+
+ if (defined $scale)
+ {
+ $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+ $scale = int($scale);
+ }
+
+ ($scale,$mode);
+ }
+
+##############################################################################
+# constructors
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ if (@_ > 1)
+ {
+ my $self = bless {
+ sign => $_[1]->{sign},
+ value => $CALC->_copy($_[1]->{value}),
+ }, $_[0] if @_ > 1;
+
+ $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
+ $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
+ return $self;
+ }
+
+ my $self = bless {
+ sign => $_[0]->{sign},
+ value => $CALC->_copy($_[0]->{value}),
+ }, ref($_[0]);
+
+ $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
+ $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
+ $self;
+ }
+
+sub new
+ {
+ # create a new BigInt object from a string or another BigInt object.
+ # see hash keys documented at top
+
+ # the argument could be an object, so avoid ||, && etc on it, this would
+ # cause costly overloaded code to be called. The only allowed ops are
+ # ref() and defined.
+
+ my ($class,$wanted,$a,$p,$r) = @_;
+
+ # avoid numify-calls by not using || on $wanted!
+ return $class->bzero($a,$p) if !defined $wanted; # default to 0
+ return $class->copy($wanted,$a,$p,$r)
+ if ref($wanted) && $wanted->isa($class); # MBI or subclass
+
+ $class->import() if $IMPORT == 0; # make require work
+
+ my $self = bless {}, $class;
+
+ # shortcut for "normal" numbers
+ if ((!ref $wanted) && ($wanted =~ /^([+-]?)[1-9][0-9]*\z/))
+ {
+ $self->{sign} = $1 || '+';
+
+ if ($wanted =~ /^[+-]/)
+ {
+ # remove sign without touching wanted to make it work with constants
+ my $t = $wanted; $t =~ s/^[+-]//;
+ $self->{value} = $CALC->_new($t);
+ }
+ else
+ {
+ $self->{value} = $CALC->_new($wanted);
+ }
+ no strict 'refs';
+ if ( (defined $a) || (defined $p)
+ || (defined ${"${class}::precision"})
+ || (defined ${"${class}::accuracy"})
+ )
+ {
+ $self->round($a,$p,$r) unless (@_ == 4 && !defined $a && !defined $p);
+ }
+ return $self;
+ }
+
+ # handle '+inf', '-inf' first
+ if ($wanted =~ /^[+-]?inf\z/)
+ {
+ $self->{sign} = $wanted; # set a default sign for bstr()
+ return $self->binf($wanted);
+ }
+ # split str in m mantissa, e exponent, i integer, f fraction, v value, s sign
+ my ($mis,$miv,$mfv,$es,$ev) = _split($wanted);
+ if (!ref $mis)
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted is not a number in $class");
+ }
+ $self->{value} = $CALC->_zero();
+ $self->{sign} = $nan;
+ return $self;
+ }
+ if (!ref $miv)
+ {
+ # _from_hex or _from_bin
+ $self->{value} = $mis->{value};
+ $self->{sign} = $mis->{sign};
+ return $self; # throw away $mis
+ }
+ # make integer from mantissa by adjusting exp, then convert to bigint
+ $self->{sign} = $$mis; # store sign
+ $self->{value} = $CALC->_zero(); # for all the NaN cases
+ my $e = int("$$es$$ev"); # exponent (avoid recursion)
+ if ($e > 0)
+ {
+ my $diff = $e - CORE::length($$mfv);
+ if ($diff < 0) # Not integer
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 1\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ else # diff >= 0
+ {
+ # adjust fraction and add it to value
+ #print "diff > 0 $$miv\n";
+ $$miv = $$miv . ($$mfv . '0' x $diff);
+ }
+ }
+ else
+ {
+ if ($$mfv ne '') # e <= 0
+ {
+ # fraction and negative/zero E => NOI
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 2 \$\$mfv '$$mfv'\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ elsif ($e < 0)
+ {
+ # xE-y, and empty mfv
+ #print "xE-y\n";
+ $e = abs($e);
+ if ($$miv !~ s/0{$e}$//) # can strip so many zero's?
+ {
+ if ($_trap_nan)
+ {
+ require Carp; Carp::croak("$wanted not an integer in $class");
+ }
+ #print "NOI 3\n";
+ return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
+ $self->{sign} = $nan;
+ }
+ }
+ }
+ $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0
+ $self->{value} = $CALC->_new($$miv) if $self->{sign} =~ /^[+-]$/;
+ # if any of the globals is set, use them to round and store them inside $self
+ # do not round for new($x,undef,undef) since that is used by MBF to signal
+ # no rounding
+ $self->round($a,$p,$r) unless @_ == 4 && !defined $a && !defined $p;
+ $self;
+ }
+
+sub bnan
+ {
+ # create a bigint 'NaN', if given a BigInt, set it to 'NaN'
+ my $self = shift;
+ $self = $class if !defined $self;
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ no strict 'refs';
+ if (${"${class}::_trap_nan"})
+ {
+ require Carp;
+ Carp::croak ("Tried to set $self to NaN in $class\::bnan()");
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bnan');
+ if ($self->can('_bnan'))
+ {
+ # use subclass to initialize
+ $self->_bnan();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $self->{sign} = $nan;
+ delete $self->{_a}; delete $self->{_p}; # rounding NaN is silly
+ $self;
+ }
+
+sub binf
+ {
+ # create a bigint '+-inf', if given a BigInt, set it to '+-inf'
+ # the sign is either '+', or if given, used from there
+ my $self = shift;
+ my $sign = shift; $sign = '+' if !defined $sign || $sign !~ /^-(inf)?$/;
+ $self = $class if !defined $self;
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ no strict 'refs';
+ if (${"${class}::_trap_inf"})
+ {
+ require Carp;
+ Carp::croak ("Tried to set $self to +-inf in $class\::binf()");
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('binf');
+ if ($self->can('_binf'))
+ {
+ # use subclass to initialize
+ $self->_binf();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $sign = $sign . 'inf' if $sign !~ /inf$/; # - => -inf
+ $self->{sign} = $sign;
+ ($self->{_a},$self->{_p}) = @_; # take over requested rounding
+ $self;
+ }
+
+sub bzero
+ {
+ # create a bigint '+0', if given a BigInt, set it to 0
+ my $self = shift;
+ $self = __PACKAGE__ if !defined $self;
+
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bzero');
+
+ if ($self->can('_bzero'))
+ {
+ # use subclass to initialize
+ $self->_bzero();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_zero();
+ }
+ $self->{sign} = '+';
+ if (@_ > 0)
+ {
+ if (@_ > 3)
+ {
+ # call like: $x->bzero($a,$p,$r,$y);
+ ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
+ }
+ else
+ {
+ $self->{_a} = $_[0]
+ if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
+ $self->{_p} = $_[1]
+ if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
+ }
+ }
+ $self;
+ }
+
+sub bone
+ {
+ # create a bigint '+1' (or -1 if given sign '-'),
+ # if given a BigInt, set it to +1 or -1, respectively
+ my $self = shift;
+ my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
+ $self = $class if !defined $self;
+
+ if (!ref($self))
+ {
+ my $c = $self; $self = {}; bless $self, $c;
+ }
+ $self->import() if $IMPORT == 0; # make require work
+ return if $self->modify('bone');
+
+ if ($self->can('_bone'))
+ {
+ # use subclass to initialize
+ $self->_bone();
+ }
+ else
+ {
+ # otherwise do our own thing
+ $self->{value} = $CALC->_one();
+ }
+ $self->{sign} = $sign;
+ if (@_ > 0)
+ {
+ if (@_ > 3)
+ {
+ # call like: $x->bone($sign,$a,$p,$r,$y);
+ ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
+ }
+ else
+ {
+ # call like: $x->bone($sign,$a,$p,$r);
+ $self->{_a} = $_[0]
+ if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
+ $self->{_p} = $_[1]
+ if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
+ }
+ }
+ $self;
+ }
+
+##############################################################################
+# string conversation
+
+sub bsstr
+ {
+ # (ref to BFLOAT or num_str ) return num_str
+ # Convert number from internal format to scientific string format.
+ # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my ($m,$e) = $x->parts();
+ #$m->bstr() . 'e+' . $e->bstr(); # e can only be positive in BigInt
+ # 'e+' because E can only be positive in BigInt
+ $m->bstr() . 'e+' . $CALC->_str($e->{value});
+ }
+
+sub bstr
+ {
+ # make a string from bigint object
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
+ return 'inf'; # +inf
+ }
+ my $es = ''; $es = $x->{sign} if $x->{sign} eq '-';
+ $es.$CALC->_str($x->{value});
+ }
+
+sub numify
+ {
+ # Make a "normal" scalar from a BigInt object
+ my $x = shift; $x = $class->new($x) unless ref $x;
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/;
+ my $num = $CALC->_num($x->{value});
+ return -$num if $x->{sign} eq '-';
+ $num;
+ }
+
+##############################################################################
+# public stuff (usually prefixed with "b")
+
+sub sign
+ {
+ # return the sign of the number: +/-/-inf/+inf/NaN
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign};
+ }
+
+sub _find_round_parameters
+ {
+ # After any operation or when calling round(), the result is rounded by
+ # regarding the A & P from arguments, local parameters, or globals.
+
+ # !!!!!!! If you change this, remember to change round(), too! !!!!!!!!!!
+
+ # This procedure finds the round parameters, but it is for speed reasons
+ # duplicated in round. Otherwise, it is tested by the testsuite and used
+ # by fdiv().
+
+ # returns ($self) or ($self,$a,$p,$r) - sets $self to NaN of both A and P
+ # were requested/defined (locally or globally or both)
+
+ my ($self,$a,$p,$r,@args) = @_;
+ # $a accuracy, if given by caller
+ # $p precision, if given by caller
+ # $r round_mode, if given by caller
+ # @args all 'other' arguments (0 for unary, 1 for binary ops)
+
+ my $c = ref($self); # find out class of argument(s)
+ no strict 'refs';
+
+ # convert to normal scalar for speed and correctness in inner parts
+ $a = $a->can('numify') ? $a->numify() : "$a" if defined $a && ref($a);
+ $p = $p->can('numify') ? $p->numify() : "$p" if defined $p && ref($p);
+
+ # now pick $a or $p, but only if we have got "arguments"
+ if (!defined $a)
+ {
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is smaller
+ $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
+ }
+ }
+ if (!defined $p)
+ {
+ # even if $a is defined, take $p, to signal error for both defined
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is bigger
+ # -2 > -3, and 3 > 2
+ $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
+ }
+ }
+ # if still none defined, use globals (#2)
+ $a = ${"$c\::accuracy"} unless defined $a;
+ $p = ${"$c\::precision"} unless defined $p;
+
+ # A == 0 is useless, so undef it to signal no rounding
+ $a = undef if defined $a && $a == 0;
+
+ # no rounding today?
+ return ($self) unless defined $a || defined $p; # early out
+
+ # set A and set P is an fatal error
+ return ($self->bnan()) if defined $a && defined $p; # error
+
+ $r = ${"$c\::round_mode"} unless defined $r;
+ if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$r'");
+ }
+
+ $a = int($a) if defined $a;
+ $p = int($p) if defined $p;
+
+ ($self,$a,$p,$r);
+ }
+
+sub round
+ {
+ # Round $self according to given parameters, or given second argument's
+ # parameters or global defaults
+
+ # for speed reasons, _find_round_parameters is embeded here:
+
+ my ($self,$a,$p,$r,@args) = @_;
+ # $a accuracy, if given by caller
+ # $p precision, if given by caller
+ # $r round_mode, if given by caller
+ # @args all 'other' arguments (0 for unary, 1 for binary ops)
+
+ my $c = ref($self); # find out class of argument(s)
+ no strict 'refs';
+
+ # now pick $a or $p, but only if we have got "arguments"
+ if (!defined $a)
+ {
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is smaller
+ $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
+ }
+ }
+ if (!defined $p)
+ {
+ # even if $a is defined, take $p, to signal error for both defined
+ foreach ($self,@args)
+ {
+ # take the defined one, or if both defined, the one that is bigger
+ # -2 > -3, and 3 > 2
+ $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
+ }
+ }
+ # if still none defined, use globals (#2)
+ $a = ${"$c\::accuracy"} unless defined $a;
+ $p = ${"$c\::precision"} unless defined $p;
+
+ # A == 0 is useless, so undef it to signal no rounding
+ $a = undef if defined $a && $a == 0;
+
+ # no rounding today?
+ return $self unless defined $a || defined $p; # early out
+
+ # set A and set P is an fatal error
+ return $self->bnan() if defined $a && defined $p;
+
+ $r = ${"$c\::round_mode"} unless defined $r;
+ if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
+ {
+ require Carp; Carp::croak ("Unknown round mode '$r'");
+ }
+
+ # now round, by calling either fround or ffround:
+ if (defined $a)
+ {
+ $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
+ }
+ else # both can't be undefined due to early out
+ {
+ $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
+ }
+ # bround() or bfround() already callled bnorm() if nec.
+ $self;
+ }
+
+sub bnorm
+ {
+ # (numstr or BINT) return BINT
+ # Normalize number -- no-op here
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+ $x;
+ }
+
+sub babs
+ {
+ # (BINT or num_str) return BINT
+ # make number absolute, or return absolute BINT from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('babs');
+ # post-normalized abs for internal use (does nothing for NaN)
+ $x->{sign} =~ s/^-/+/;
+ $x;
+ }
+
+sub bneg
+ {
+ # (BINT or num_str) return BINT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $CALC->_is_zero($x->{value}));
+ $x;
+ }
+
+sub bcmp
+ {
+ # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT or num_str, BINT or num_str) return cond_code
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bcmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # have same sign, so compare absolute values. Don't make tests for zero here
+ # because it's actually slower than testin in Calc (especially w/ Pari et al)
+
+ # post-normalized compare for internal use (honors signs)
+ if ($x->{sign} eq '+')
+ {
+ # $x and $y both > 0
+ return $CALC->_acmp($x->{value},$y->{value});
+ }
+
+ # $x && $y both < 0
+ $CALC->_acmp($y->{value},$x->{value}); # swaped acmp (lib returns 0,1,-1)
+ }
+
+sub bacmp
+ {
+ # Compares 2 values, ignoring their signs.
+ # Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT, BINT) return cond_code
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ return $upgrade->bacmp($x,$y) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
+ return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
+ return -1;
+ }
+ $CALC->_acmp($x->{value},$y->{value}); # lib does only 0,1,-1
+ }
+
+sub badd
+ {
+ # add second arg (BINT or string) to first (BINT) (modifies first)
+ # return result as BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('badd');
+ return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ $r[3] = $y; # no push!
+ # inf and NaN handling
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # NaN first
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +inf++inf or -inf+-inf => same, rest is NaN
+ return $x if $x->{sign} eq $y->{sign};
+ return $x->bnan();
+ }
+ # +-inf + something => +inf
+ # something +-inf => +-inf
+ $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
+ return $x;
+ }
+
+ my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs
+
+ if ($sx eq $sy)
+ {
+ $x->{value} = $CALC->_add($x->{value},$y->{value}); # same sign, abs add
+ }
+ else
+ {
+ my $a = $CALC->_acmp ($y->{value},$x->{value}); # absolute compare
+ if ($a > 0)
+ {
+ $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap
+ $x->{sign} = $sy;
+ }
+ elsif ($a == 0)
+ {
+ # speedup, if equal, set result to 0
+ $x->{value} = $CALC->_zero();
+ $x->{sign} = '+';
+ }
+ else # a < 0
+ {
+ $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
+ }
+ }
+ $x->round(@r);
+ }
+
+sub bsub
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # subtract second arg from first, modify first
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bsub');
+
+ return $upgrade->new($x)->bsub($upgrade->new($y),@r) if defined $upgrade &&
+ ((!$x->isa($self)) || (!$y->isa($self)));
+
+ return $x->round(@r) if $y->is_zero();
+
+ # To correctly handle the lone special case $x->bsub($x), we note the sign
+ # of $x, then flip the sign from $y, and if the sign of $x did change, too,
+ # then we caught the special case:
+ my $xsign = $x->{sign};
+ $y->{sign} =~ tr/+\-/-+/; # does nothing for NaN
+ if ($xsign ne $x->{sign})
+ {
+ # special case of $x->bsub($x) results in 0
+ return $x->bzero(@r) if $xsign =~ /^[+-]$/;
+ return $x->bnan(); # NaN, -inf, +inf
+ }
+ $x->badd($y,@r); # badd does not leave internal zeros
+ $y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN)
+ $x; # already rounded by badd() or no round nec.
+ }
+
+sub binc
+ {
+ # increment arg by one
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('binc');
+
+ if ($x->{sign} eq '+')
+ {
+ $x->{value} = $CALC->_inc($x->{value});
+ return $x->round($a,$p,$r);
+ }
+ elsif ($x->{sign} eq '-')
+ {
+ $x->{value} = $CALC->_dec($x->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
+ return $x->round($a,$p,$r);
+ }
+ # inf, nan handling etc
+ $x->badd($self->bone(),$a,$p,$r); # badd does round
+ }
+
+sub bdec
+ {
+ # decrement arg by one
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('bdec');
+
+ if ($x->{sign} eq '-')
+ {
+ # x already < 0
+ $x->{value} = $CALC->_inc($x->{value});
+ }
+ else
+ {
+ return $x->badd($self->bone('-'),@r) unless $x->{sign} eq '+'; # inf or NaN
+ # >= 0
+ if ($CALC->_is_zero($x->{value}))
+ {
+ # == 0
+ $x->{value} = $CALC->_one(); $x->{sign} = '-'; # 0 => -1
+ }
+ else
+ {
+ # > 0
+ $x->{value} = $CALC->_dec($x->{value});
+ }
+ }
+ $x->round(@r);
+ }
+
+sub blog
+ {
+ # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base
+ # $base of $x)
+
+ # set up parameters
+ my ($self,$x,$base,@r) = (undef,@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$base,@r) = objectify(1,ref($x),@_);
+ }
+
+ return $x if $x->modify('blog');
+
+ $base = $self->new($base) if defined $base && !ref $base;
+
+ # inf, -inf, NaN, <0 => NaN
+ return $x->bnan()
+ if $x->{sign} ne '+' || (defined $base && $base->{sign} ne '+');
+
+ return $upgrade->blog($upgrade->new($x),$base,@r) if
+ defined $upgrade;
+
+ # fix for bug #24969:
+ # the default base is e (Euler's number) which is not an integer
+ if (!defined $base)
+ {
+ require Math::BigFloat;
+ my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int();
+ # modify $x in place
+ $x->{value} = $u->{value};
+ $x->{sign} = $u->{sign};
+ return $x;
+ }
+
+ my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value});
+ return $x->bnan() unless defined $rc; # not possible to take log?
+ $x->{value} = $rc;
+ $x->round(@r);
+ }
+
+sub bnok
+ {
+ # Calculate n over k (binomial coefficient or "choose" function) as integer.
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bnok');
+ return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
+ return $x->binf() if $x->{sign} eq '+inf';
+
+ # k > n or k < 0 => 0
+ my $cmp = $x->bacmp($y);
+ return $x->bzero() if $cmp < 0 || $y->{sign} =~ /^-/;
+ # k == n => 1
+ return $x->bone(@r) if $cmp == 0;
+
+ if ($CALC->can('_nok'))
+ {
+ $x->{value} = $CALC->_nok($x->{value},$y->{value});
+ }
+ else
+ {
+ # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
+ # ( - ) = --------- = --------------- = ---------
+ # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
+
+ # compute n - k + 2 (so we start with 5 in the example above)
+ my $z = $x - $y;
+ if (!$z->is_one())
+ {
+ $z->binc();
+ my $r = $z->copy(); $z->binc();
+ my $d = $self->new(2);
+ while ($z->bacmp($x) <= 0) # f < x ?
+ {
+ $r->bmul($z); $r->bdiv($d);
+ $z->binc(); $d->binc();
+ }
+ $x->{value} = $r->{value}; $x->{sign} = '+';
+ }
+ else { $x->bone(); }
+ }
+ $x->round(@r);
+ }
+
+sub bexp
+ {
+ # Calculate e ** $x (Euler's number to the power of X), truncated to
+ # an integer value.
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+ return $x if $x->modify('bexp');
+
+ # inf, -inf, NaN, <0 => NaN
+ return $x->bnan() if $x->{sign} eq 'NaN';
+ return $x->bone() if $x->is_zero();
+ return $x if $x->{sign} eq '+inf';
+ return $x->bzero() if $x->{sign} eq '-inf';
+
+ my $u;
+ {
+ # run through Math::BigFloat unless told otherwise
+ require Math::BigFloat unless defined $upgrade;
+ local $upgrade = 'Math::BigFloat' unless defined $upgrade;
+ # calculate result, truncate it to integer
+ $u = $upgrade->bexp($upgrade->new($x),@r);
+ }
+
+ if (!defined $upgrade)
+ {
+ $u = $u->as_int();
+ # modify $x in place
+ $x->{value} = $u->{value};
+ $x->round(@r);
+ }
+ else { $x = $u; }
+ }
+
+sub blcm
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+ # Lowest Common Multiplicator
+
+ my $y = shift; my ($x);
+ if (ref($y))
+ {
+ $x = $y->copy();
+ }
+ else
+ {
+ $x = $class->new($y);
+ }
+ my $self = ref($x);
+ while (@_)
+ {
+ my $y = shift; $y = $self->new($y) if !ref ($y);
+ $x = __lcm($x,$y);
+ }
+ $x;
+ }
+
+sub bgcd
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does not modify arguments, but returns new object
+ # GCD -- Euclids algorithm, variant C (Knuth Vol 3, pg 341 ff)
+
+ my $y = shift;
+ $y = $class->new($y) if !ref($y);
+ my $self = ref($y);
+ my $x = $y->copy()->babs(); # keep arguments
+ return $x->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN?
+
+ while (@_)
+ {
+ $y = shift; $y = $self->new($y) if !ref($y);
+ return $x->bnan() if $y->{sign} !~ /^[+-]$/; # y NaN?
+ $x->{value} = $CALC->_gcd($x->{value},$y->{value});
+ last if $CALC->_is_one($x->{value});
+ }
+ $x;
+ }
+
+sub bnot
+ {
+ # (num_str or BINT) return BINT
+ # represent ~x as twos-complement number
+ # we don't need $self, so undef instead of ref($_[0]) make it slightly faster
+ my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bnot');
+ $x->binc()->bneg(); # binc already does round
+ }
+
+##############################################################################
+# is_foo test routines
+# we don't need $self, so undef instead of ref($_[0]) make it slightly faster
+
+sub is_zero
+ {
+ # return true if arg (BINT or num_str) is zero (array '+', '0')
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't
+ $CALC->_is_zero($x->{value});
+ }
+
+sub is_nan
+ {
+ # return true if arg (BINT or num_str) is NaN
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} eq $nan ? 1 : 0;
+ }
+
+sub is_inf
+ {
+ # return true if arg (BINT or num_str) is +-inf
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ if (defined $sign)
+ {
+ $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf
+ $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-'
+ return $x->{sign} =~ /^$sign$/ ? 1 : 0;
+ }
+ $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity
+ }
+
+sub is_one
+ {
+ # return true if arg (BINT or num_str) is +1, or -1 if sign is given
+ my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $sign = '+' if !defined $sign || $sign ne '-';
+
+ return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either
+ $CALC->_is_one($x->{value});
+ }
+
+sub is_odd
+ {
+ # return true when arg (BINT or num_str) is odd, false for even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ $CALC->_is_odd($x->{value});
+ }
+
+sub is_even
+ {
+ # return true when arg (BINT or num_str) is even, false for odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ $CALC->_is_even($x->{value});
+ }
+
+sub is_positive
+ {
+ # return true when arg (BINT or num_str) is positive (>= 0)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if $x->{sign} eq '+inf'; # +inf is positive
+
+ # 0+ is neither positive nor negative
+ ($x->{sign} eq '+' && !$x->is_zero()) ? 1 : 0;
+ }
+
+sub is_negative
+ {
+ # return true when arg (BINT or num_str) is negative (< 0)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not
+ }
+
+sub is_int
+ {
+ # return true when arg (BINT or num_str) is an integer
+ # always true for BigInt, but different for BigFloats
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't
+ }
+
+###############################################################################
+
+sub bmul
+ {
+ # multiply the first number by the second number
+ # (BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmul');
+
+ return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ return $upgrade->bmul($x,$upgrade->new($y),@r)
+ if defined $upgrade && !$y->isa($self);
+
+ $r[3] = $y; # no push here
+
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
+
+ $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
+
+ $x->round(@r);
+ }
+
+sub bmuladd
+ {
+ # multiply two numbers and then add the third to the result
+ # (BINT or num_str, BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$z,@r) = objectify(3,@_);
+ }
+
+ return $x if $x->modify('bmuladd');
+
+ return $x->bnan() if ($x->{sign} eq $nan) ||
+ ($y->{sign} eq $nan) ||
+ ($z->{sign} eq $nan);
+
+ # inf handling of x and y
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+ # inf handling x*y and z
+ if (($z->{sign} =~ /^[+-]inf$/))
+ {
+ # something +-inf => +-inf
+ $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
+ }
+
+ return $upgrade->bmuladd($x,$upgrade->new($y),$upgrade->new($z),@r)
+ if defined $upgrade && (!$y->isa($self) || !$z->isa($self) || !$x->isa($self));
+
+ # TODO: what if $y and $z have A or P set?
+ $r[3] = $z; # no push here
+
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
+
+ $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
+
+ my ($sx, $sz) = ( $x->{sign}, $z->{sign} ); # get signs
+
+ if ($sx eq $sz)
+ {
+ $x->{value} = $CALC->_add($x->{value},$z->{value}); # same sign, abs add
+ }
+ else
+ {
+ my $a = $CALC->_acmp ($z->{value},$x->{value}); # absolute compare
+ if ($a > 0)
+ {
+ $x->{value} = $CALC->_sub($z->{value},$x->{value},1); # abs sub w/ swap
+ $x->{sign} = $sz;
+ }
+ elsif ($a == 0)
+ {
+ # speedup, if equal, set result to 0
+ $x->{value} = $CALC->_zero();
+ $x->{sign} = '+';
+ }
+ else # a < 0
+ {
+ $x->{value} = $CALC->_sub($x->{value}, $z->{value}); # abs sub
+ }
+ }
+ $x->round(@r);
+ }
+
+sub _div_inf
+ {
+ # helper function that handles +-inf cases for bdiv()/bmod() to reuse code
+ my ($self,$x,$y) = @_;
+
+ # NaN if x == NaN or y == NaN or x==y==0
+ return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan()
+ if (($x->is_nan() || $y->is_nan()) ||
+ ($x->is_zero() && $y->is_zero()));
+
+ # +-inf / +-inf == NaN, reminder also NaN
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan();
+ }
+ # x / +-inf => 0, remainder x (works even if x == 0)
+ if ($y->{sign} =~ /^[+-]inf$/)
+ {
+ my $t = $x->copy(); # bzero clobbers up $x
+ return wantarray ? ($x->bzero(),$t) : $x->bzero()
+ }
+
+ # 5 / 0 => +inf, -6 / 0 => -inf
+ # +inf / 0 = inf, inf, and -inf / 0 => -inf, -inf
+ # exception: -8 / 0 has remainder -8, not 8
+ # exception: -inf / 0 has remainder -inf, not inf
+ if ($y->is_zero())
+ {
+ # +-inf / 0 => special case for -inf
+ return wantarray ? ($x,$x->copy()) : $x if $x->is_inf();
+ if (!$x->is_zero() && !$x->is_inf())
+ {
+ my $t = $x->copy(); # binf clobbers up $x
+ return wantarray ?
+ ($x->binf($x->{sign}),$t) : $x->binf($x->{sign})
+ }
+ }
+
+ # last case: +-inf / ordinary number
+ my $sign = '+inf';
+ $sign = '-inf' if substr($x->{sign},0,1) ne $y->{sign};
+ $x->{sign} = $sign;
+ return wantarray ? ($x,$self->bzero()) : $x;
+ }
+
+sub bdiv
+ {
+ # (dividend: BINT or num_str, divisor: BINT or num_str) return
+ # (BINT,BINT) (quo,rem) or BINT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bdiv');
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ return $upgrade->bdiv($upgrade->new($x),$upgrade->new($y),@r)
+ if defined $upgrade;
+
+ $r[3] = $y; # no push!
+
+ # calc new sign and in case $y == +/- 1, return $x
+ my $xsign = $x->{sign}; # keep
+ $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+');
+
+ if (wantarray)
+ {
+ my $rem = $self->bzero();
+ ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+ $rem->{_a} = $x->{_a};
+ $rem->{_p} = $x->{_p};
+ $x->round(@r);
+ if (! $CALC->_is_zero($rem->{value}))
+ {
+ $rem->{sign} = $y->{sign};
+ $rem = $y->copy()->bsub($rem) if $xsign ne $y->{sign}; # one of them '-'
+ }
+ else
+ {
+ $rem->{sign} = '+'; # dont leave -0
+ }
+ $rem->round(@r);
+ return ($x,$rem);
+ }
+
+ $x->{value} = $CALC->_div($x->{value},$y->{value});
+ $x->{sign} = '+' if $CALC->_is_zero($x->{value});
+
+ $x->round(@r);
+ }
+
+###############################################################################
+# modulus functions
+
+sub bmod
+ {
+ # modulus (or remainder)
+ # (BINT or num_str, BINT or num_str) return BINT
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmod');
+ $r[3] = $y; # no push!
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero())
+ {
+ my ($d,$r) = $self->_div_inf($x,$y);
+ $x->{sign} = $r->{sign};
+ $x->{value} = $r->{value};
+ return $x->round(@r);
+ }
+
+ # calc new sign and in case $y == +/- 1, return $x
+ $x->{value} = $CALC->_mod($x->{value},$y->{value});
+ if (!$CALC->_is_zero($x->{value}))
+ {
+ $x->{value} = $CALC->_sub($y->{value},$x->{value},1) # $y-$x
+ if ($x->{sign} ne $y->{sign});
+ $x->{sign} = $y->{sign};
+ }
+ else
+ {
+ $x->{sign} = '+'; # dont leave -0
+ }
+ $x->round(@r);
+ }
+
+sub bmodinv
+ {
+ # Modular inverse. given a number which is (hopefully) relatively
+ # prime to the modulus, calculate its inverse using Euclid's
+ # alogrithm. If the number is not relatively prime to the modulus
+ # (i.e. their gcd is not one) then NaN is returned.
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (undef,@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bmodinv');
+
+ return $x->bnan()
+ if ($y->{sign} ne '+' # -, NaN, +inf, -inf
+ || $x->is_zero() # or num == 0
+ || $x->{sign} !~ /^[+-]$/ # or num NaN, inf, -inf
+ );
+
+ # put least residue into $x if $x was negative, and thus make it positive
+ $x->bmod($y) if $x->{sign} eq '-';
+
+ my $sign;
+ ($x->{value},$sign) = $CALC->_modinv($x->{value},$y->{value});
+ return $x->bnan() if !defined $x->{value}; # in case no GCD found
+ return $x if !defined $sign; # already real result
+ $x->{sign} = $sign; # flip/flop see below
+ $x->bmod($y); # calc real result
+ $x;
+ }
+
+sub bmodpow
+ {
+ # takes a very large number to a very large exponent in a given very
+ # large modulus, quickly, thanks to binary exponentation. Supports
+ # negative exponents.
+ my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
+
+ return $num if $num->modify('bmodpow');
+
+ # check modulus for valid values
+ return $num->bnan() if ($mod->{sign} ne '+' # NaN, - , -inf, +inf
+ || $mod->is_zero());
+
+ # check exponent for valid values
+ if ($exp->{sign} =~ /\w/)
+ {
+ # i.e., if it's NaN, +inf, or -inf...
+ return $num->bnan();
+ }
+
+ $num->bmodinv ($mod) if ($exp->{sign} eq '-');
+
+ # check num for valid values (also NaN if there was no inverse but $exp < 0)
+ return $num->bnan() if $num->{sign} !~ /^[+-]$/;
+
+ # $mod is positive, sign on $exp is ignored, result also positive
+ $num->{value} = $CALC->_modpow($num->{value},$exp->{value},$mod->{value});
+ $num;
+ }
+
+###############################################################################
+
+sub bfac
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute factorial number from $x, modify $x in place
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; # inf => inf
+ return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN
+
+ $x->{value} = $CALC->_fac($x->{value});
+ $x->round(@r);
+ }
+
+sub bpow
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
+ # modifies first argument
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bpow');
+
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
+ {
+ # +-inf ** +-inf
+ return $x->bnan();
+ }
+ # +-inf ** Y
+ if ($x->{sign} =~ /^[+-]inf/)
+ {
+ # +inf ** 0 => NaN
+ return $x->bnan() if $y->is_zero();
+ # -inf ** -1 => 1/inf => 0
+ return $x->bzero() if $y->is_one('-') && $x->is_negative();
+
+ # +inf ** Y => inf
+ return $x if $x->{sign} eq '+inf';
+
+ # -inf ** Y => -inf if Y is odd
+ return $x if $y->is_odd();
+ return $x->babs();
+ }
+ # X ** +-inf
+
+ # 1 ** +inf => 1
+ return $x if $x->is_one();
+
+ # 0 ** inf => 0
+ return $x if $x->is_zero() && $y->{sign} =~ /^[+]/;
+
+ # 0 ** -inf => inf
+ return $x->binf() if $x->is_zero();
+
+ # -1 ** -inf => NaN
+ return $x->bnan() if $x->is_one('-') && $y->{sign} =~ /^[-]/;
+
+ # -X ** -inf => 0
+ return $x->bzero() if $x->{sign} eq '-' && $y->{sign} =~ /^[-]/;
+
+ # -1 ** inf => NaN
+ return $x->bnan() if $x->{sign} eq '-';
+
+ # X ** inf => inf
+ return $x->binf() if $y->{sign} =~ /^[+]/;
+ # X ** -inf => 0
+ return $x->bzero();
+ }
+
+ return $upgrade->bpow($upgrade->new($x),$y,@r)
+ if defined $upgrade && (!$y->isa($self) || $y->{sign} eq '-');
+
+ $r[3] = $y; # no push!
+
+ # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu
+
+ my $new_sign = '+';
+ $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+');
+
+ # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf
+ return $x->binf()
+ if $y->{sign} eq '-' && $x->{sign} eq '+' && $CALC->_is_zero($x->{value});
+ # 1 ** -y => 1 / (1 ** |y|)
+ # so do test for negative $y after above's clause
+ return $x->bnan() if $y->{sign} eq '-' && !$CALC->_is_one($x->{value});
+
+ $x->{value} = $CALC->_pow($x->{value},$y->{value});
+ $x->{sign} = $new_sign;
+ $x->{sign} = '+' if $CALC->_is_zero($y->{value});
+ $x->round(@r);
+ }
+
+sub blsft
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute x << y, base n, y >= 0
+
+ # set up parameters
+ my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('blsft');
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+ return $x->round(@r) if $y->is_zero();
+
+ $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
+
+ $x->{value} = $CALC->_lsft($x->{value},$y->{value},$n);
+ $x->round(@r);
+ }
+
+sub brsft
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # compute x >> y, base n, y >= 0
+
+ # set up parameters
+ my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$n,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('brsft');
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+ return $x->round(@r) if $y->is_zero();
+ return $x->bzero(@r) if $x->is_zero(); # 0 => 0
+
+ $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
+
+ # this only works for negative numbers when shifting in base 2
+ if (($x->{sign} eq '-') && ($n == 2))
+ {
+ return $x->round(@r) if $x->is_one('-'); # -1 => -1
+ if (!$y->is_one())
+ {
+ # although this is O(N*N) in calc (as_bin!) it is O(N) in Pari et al
+ # but perhaps there is a better emulation for two's complement shift...
+ # if $y != 1, we must simulate it by doing:
+ # convert to bin, flip all bits, shift, and be done
+ $x->binc(); # -3 => -2
+ my $bin = $x->as_bin();
+ $bin =~ s/^-0b//; # strip '-0b' prefix
+ $bin =~ tr/10/01/; # flip bits
+ # now shift
+ if ($y >= CORE::length($bin))
+ {
+ $bin = '0'; # shifting to far right creates -1
+ # 0, because later increment makes
+ # that 1, attached '-' makes it '-1'
+ # because -1 >> x == -1 !
+ }
+ else
+ {
+ $bin =~ s/.{$y}$//; # cut off at the right side
+ $bin = '1' . $bin; # extend left side by one dummy '1'
+ $bin =~ tr/10/01/; # flip bits back
+ }
+ my $res = $self->new('0b'.$bin); # add prefix and convert back
+ $res->binc(); # remember to increment
+ $x->{value} = $res->{value}; # take over value
+ return $x->round(@r); # we are done now, magic, isn't?
+ }
+ # x < 0, n == 2, y == 1
+ $x->bdec(); # n == 2, but $y == 1: this fixes it
+ }
+
+ $x->{value} = $CALC->_rsft($x->{value},$y->{value},$n);
+ $x->round(@r);
+ }
+
+sub band
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x & y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('band');
+
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_and($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ if ($CAN{signed_and})
+ {
+ $x->{value} = $CALC->_signed_and($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_band($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub bior
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x | y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bior');
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ # the sign of X follows the sign of X, e.g. sign of Y irrelevant for bior()
+
+ # don't use lib for negative values
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_or($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ # if lib can do negative values, let it handle this
+ if ($CAN{signed_or})
+ {
+ $x->{value} = $CALC->_signed_or($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_bior($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub bxor
+ {
+ #(BINT or num_str, BINT or num_str) return BINT
+ # compute x ^ y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->modify('bxor');
+ $r[3] = $y; # no push!
+
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ my $sx = $x->{sign} eq '+' ? 1 : -1;
+ my $sy = $y->{sign} eq '+' ? 1 : -1;
+
+ # don't use lib for negative values
+ if ($sx == 1 && $sy == 1)
+ {
+ $x->{value} = $CALC->_xor($x->{value},$y->{value});
+ return $x->round(@r);
+ }
+
+ # if lib can do negative values, let it handle this
+ if ($CAN{signed_xor})
+ {
+ $x->{value} = $CALC->_signed_xor($x->{value},$y->{value},$sx,$sy);
+ return $x->round(@r);
+ }
+
+ require $EMU_LIB;
+ __emu_bxor($self,$x,$y,$sx,$sy,@r);
+ }
+
+sub length
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ my $e = $CALC->_len($x->{value});
+ wantarray ? ($e,0) : $e;
+ }
+
+sub digit
+ {
+ # return the nth decimal digit, negative values count backward, 0 is right
+ my ($self,$x,$n) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $n = $n->numify() if ref($n);
+ $CALC->_digit($x->{value},$n||0);
+ }
+
+sub _trailing_zeros
+ {
+ # return the amount of trailing zeros in $x (as scalar)
+ my $x = shift;
+ $x = $class->new($x) unless ref $x;
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc
+
+ $CALC->_zeros($x->{value}); # must handle odd values, 0 etc
+ }
+
+sub bsqrt
+ {
+ # calculate square root of $x
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsqrt');
+
+ return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN
+ return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf
+
+ return $upgrade->bsqrt($x,@r) if defined $upgrade;
+
+ $x->{value} = $CALC->_sqrt($x->{value});
+ $x->round(@r);
+ }
+
+sub broot
+ {
+ # calculate $y'th root of $x
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ $y = $self->new(2) unless defined $y;
+
+ # objectify is costly, so avoid it
+ if ((!ref($x)) || (ref($x) ne ref($y)))
+ {
+ ($self,$x,$y,@r) = objectify(2,$self || $class,@_);
+ }
+
+ return $x if $x->modify('broot');
+
+ # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
+ return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
+ $y->{sign} !~ /^\+$/;
+
+ return $x->round(@r)
+ if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
+
+ return $upgrade->new($x)->broot($upgrade->new($y),@r) if defined $upgrade;
+
+ $x->{value} = $CALC->_root($x->{value},$y->{value});
+ $x->round(@r);
+ }
+
+sub exponent
+ {
+ # return a copy of the exponent (here always 0, NaN or 1 for $m == 0)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf,+inf => NaN or inf
+ return $self->new($s);
+ }
+ return $self->bone() if $x->is_zero();
+
+ # 12300 => 2 trailing zeros => exponent is 2
+ $self->new( $CALC->_zeros($x->{value}) );
+ }
+
+sub mantissa
+ {
+ # return the mantissa (compatible to Math::BigFloat, e.g. reduced)
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/)
+ {
+ # for NaN, +inf, -inf: keep the sign
+ return $self->new($x->{sign});
+ }
+ my $m = $x->copy(); delete $m->{_p}; delete $m->{_a};
+
+ # that's a bit inefficient:
+ my $zeros = $CALC->_zeros($m->{value});
+ $m->brsft($zeros,10) if $zeros != 0;
+ $m;
+ }
+
+sub parts
+ {
+ # return a copy of both the exponent and the mantissa
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ ($x->mantissa(),$x->exponent());
+ }
+
+##############################################################################
+# rounding functions
+
+sub bfround
+ {
+ # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
+ # $n == 0 || $n == 1 => round to integer
+ my $x = shift; my $self = ref($x) || $x; $x = $self->new($x) unless ref $x;
+
+ my ($scale,$mode) = $x->_scale_p(@_);
+
+ return $x if !defined $scale || $x->modify('bfround'); # no-op
+
+ # no-op for BigInts if $n <= 0
+ $x->bround( $x->length()-$scale, $mode) if $scale > 0;
+
+ delete $x->{_a}; # delete to save memory
+ $x->{_p} = $scale; # store new _p
+ $x;
+ }
+
+sub _scan_for_nonzero
+ {
+ # internal, used by bround() to scan for non-zeros after a '5'
+ my ($x,$pad,$xs,$len) = @_;
+
+ return 0 if $len == 1; # "5" is trailed by invisible zeros
+ my $follow = $pad - 1;
+ return 0 if $follow > $len || $follow < 1;
+
+ # use the string form to check whether only '0's follow or not
+ substr ($xs,-$follow) =~ /[^0]/ ? 1 : 0;
+ }
+
+sub fround
+ {
+ # Exists to make life easier for switch between MBF and MBI (should we
+ # autoload fxxx() like MBF does for bxxx()?)
+ my $x = shift; $x = $class->new($x) unless ref $x;
+ $x->bround(@_);
+ }
+
+sub bround
+ {
+ # accuracy: +$n preserve $n digits from left,
+ # -$n preserve $n digits from right (f.i. for 0.1234 style in MBF)
+ # no-op for $n == 0
+ # and overwrite the rest with 0's, return normalized number
+ # do not return $x->bnorm(), but $x
+
+ my $x = shift; $x = $class->new($x) unless ref $x;
+ my ($scale,$mode) = $x->_scale_a(@_);
+ return $x if !defined $scale || $x->modify('bround'); # no-op
+
+ if ($x->is_zero() || $scale == 0)
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
+ return $x;
+ }
+ return $x if $x->{sign} !~ /^[+-]$/; # inf, NaN
+
+ # we have fewer digits than we want to scale to
+ my $len = $x->length();
+ # convert $scale to a scalar in case it is an object (put's a limit on the
+ # number length, but this would already limited by memory constraints), makes
+ # it faster
+ $scale = $scale->numify() if ref ($scale);
+
+ # scale < 0, but > -len (not >=!)
+ if (($scale < 0 && $scale < -$len-1) || ($scale >= $len))
+ {
+ $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
+ return $x;
+ }
+
+ # count of 0's to pad, from left (+) or right (-): 9 - +6 => 3, or |-6| => 6
+ my ($pad,$digit_round,$digit_after);
+ $pad = $len - $scale;
+ $pad = abs($scale-1) if $scale < 0;
+
+ # do not use digit(), it is very costly for binary => decimal
+ # getting the entire string is also costly, but we need to do it only once
+ my $xs = $CALC->_str($x->{value});
+ my $pl = -$pad-1;
+
+ # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4
+ # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3
+ $digit_round = '0'; $digit_round = substr($xs,$pl,1) if $pad <= $len;
+ $pl++; $pl ++ if $pad >= $len;
+ $digit_after = '0'; $digit_after = substr($xs,$pl,1) if $pad > 0;
+
+ # in case of 01234 we round down, for 6789 up, and only in case 5 we look
+ # closer at the remaining digits of the original $x, remember decision
+ my $round_up = 1; # default round up
+ $round_up -- if
+ ($mode eq 'trunc') || # trunc by round down
+ ($digit_after =~ /[01234]/) || # round down anyway,
+ # 6789 => round up
+ ($digit_after eq '5') && # not 5000...0000
+ ($x->_scan_for_nonzero($pad,$xs,$len) == 0) &&
+ (
+ ($mode eq 'even') && ($digit_round =~ /[24680]/) ||
+ ($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
+ ($mode eq '+inf') && ($x->{sign} eq '-') ||
+ ($mode eq '-inf') && ($x->{sign} eq '+') ||
+ ($mode eq 'zero') # round down if zero, sign adjusted below
+ );
+ my $put_back = 0; # not yet modified
+
+ if (($pad > 0) && ($pad <= $len))
+ {
+ substr($xs,-$pad,$pad) = '0' x $pad; # replace with '00...'
+ $put_back = 1; # need to put back
+ }
+ elsif ($pad > $len)
+ {
+ $x->bzero(); # round to '0'
+ }
+
+ if ($round_up) # what gave test above?
+ {
+ $put_back = 1; # need to put back
+ $pad = $len, $xs = '0' x $pad if $scale < 0; # tlr: whack 0.51=>1.0
+
+ # we modify directly the string variant instead of creating a number and
+ # adding it, since that is faster (we already have the string)
+ my $c = 0; $pad ++; # for $pad == $len case
+ while ($pad <= $len)
+ {
+ $c = substr($xs,-$pad,1) + 1; $c = '0' if $c eq '10';
+ substr($xs,-$pad,1) = $c; $pad++;
+ last if $c != 0; # no overflow => early out
+ }
+ $xs = '1'.$xs if $c == 0;
+
+ }
+ $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back, if needed
+
+ $x->{_a} = $scale if $scale >= 0;
+ if ($scale < 0)
+ {
+ $x->{_a} = $len+$scale;
+ $x->{_a} = 0 if $scale < -$len;
+ }
+ $x;
+ }
+
+sub bfloor
+ {
+ # return integer less or equal then number; no-op since it's already integer
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $x->round(@r);
+ }
+
+sub bceil
+ {
+ # return integer greater or equal then number; no-op since it's already int
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ $x->round(@r);
+ }
+
+sub as_number
+ {
+ # An object might be asked to return itself as bigint on certain overloaded
+ # operations. This does exactly this, so that sub classes can simple inherit
+ # it or override with their own integer conversion routine.
+ $_[0]->copy();
+ }
+
+sub as_hex
+ {
+ # return as hex string, with prefixed 0x
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = '';
+ $s = $x->{sign} if $x->{sign} eq '-';
+ $s . $CALC->_as_hex($x->{value});
+ }
+
+sub as_bin
+ {
+ # return as binary string, with prefixed 0b
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
+ return $s . $CALC->_as_bin($x->{value});
+ }
+
+sub as_oct
+ {
+ # return as octal string, with prefixed 0
+ my $x = shift; $x = $class->new($x) if !ref($x);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
+ return $s . $CALC->_as_oct($x->{value});
+ }
+
+##############################################################################
+# private stuff (internal use only)
+
+sub objectify
+ {
+ # check for strings, if yes, return objects instead
+
+ # the first argument is number of args objectify() should look at it will
+ # return $count+1 elements, the first will be a classname. This is because
+ # overloaded '""' calls bstr($object,undef,undef) and this would result in
+ # useless objects being created and thrown away. So we cannot simple loop
+ # over @_. If the given count is 0, all arguments will be used.
+
+ # If the second arg is a ref, use it as class.
+ # If not, try to use it as classname, unless undef, then use $class
+ # (aka Math::BigInt). The latter shouldn't happen,though.
+
+ # caller: gives us:
+ # $x->badd(1); => ref x, scalar y
+ # Class->badd(1,2); => classname x (scalar), scalar x, scalar y
+ # Class->badd( Class->(1),2); => classname x (scalar), ref x, scalar y
+ # Math::BigInt::badd(1,2); => scalar x, scalar y
+ # In the last case we check number of arguments to turn it silently into
+ # $class,1,2. (We can not take '1' as class ;o)
+ # badd($class,1) is not supported (it should, eventually, try to add undef)
+ # currently it tries 'Math::BigInt' + 1, which will not work.
+
+ # some shortcut for the common cases
+ # $x->unary_op();
+ return (ref($_[1]),$_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]);
+
+ my $count = abs(shift || 0);
+
+ my (@a,$k,$d); # resulting array, temp, and downgrade
+ if (ref $_[0])
+ {
+ # okay, got object as first
+ $a[0] = ref $_[0];
+ }
+ else
+ {
+ # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported)
+ $a[0] = $class;
+ $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first?
+ }
+
+ no strict 'refs';
+ # disable downgrading, because Math::BigFLoat->foo('1.0','2.0') needs floats
+ if (defined ${"$a[0]::downgrade"})
+ {
+ $d = ${"$a[0]::downgrade"};
+ ${"$a[0]::downgrade"} = undef;
+ }
+
+ my $up = ${"$a[0]::upgrade"};
+ # print STDERR "# Now in objectify, my class is today $a[0], count = $count\n";
+ if ($count == 0)
+ {
+ while (@_)
+ {
+ $k = shift;
+ if (!ref($k))
+ {
+ $k = $a[0]->new($k);
+ }
+ elsif (!defined $up && ref($k) ne $a[0])
+ {
+ # foreign object, try to convert to integer
+ $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
+ }
+ push @a,$k;
+ }
+ }
+ else
+ {
+ while ($count > 0)
+ {
+ $count--;
+ $k = shift;
+ if (!ref($k))
+ {
+ $k = $a[0]->new($k);
+ }
+ elsif (!defined $up && ref($k) ne $a[0])
+ {
+ # foreign object, try to convert to integer
+ $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
+ }
+ push @a,$k;
+ }
+ push @a,@_; # return other params, too
+ }
+ if (! wantarray)
+ {
+ require Carp; Carp::croak ("$class objectify needs list context");
+ }
+ ${"$a[0]::downgrade"} = $d;
+ @a;
+ }
+
+sub _register_callback
+ {
+ my ($class,$callback) = @_;
+
+ if (ref($callback) ne 'CODE')
+ {
+ require Carp;
+ Carp::croak ("$callback is not a coderef");
+ }
+ $CALLBACKS{$class} = $callback;
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $IMPORT++; # remember we did import()
+ my @a; my $l = scalar @_;
+ my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die
+ for ( my $i = 0; $i < $l ; $i++ )
+ {
+ if ($_[$i] eq ':constant')
+ {
+ # this causes overlord er load to step in
+ overload::constant
+ integer => sub { $self->new(shift) },
+ binary => sub { $self->new(shift) };
+ }
+ elsif ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ # this causes a different low lib to take care...
+ $CALC = $_[$i+1] || '';
+ # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback)
+ $warn_or_die = 1 if $_[$i] eq 'lib';
+ $warn_or_die = 2 if $_[$i] eq 'only';
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+ # any non :constant stuff is handled by our parent, Exporter
+ if (@a > 0)
+ {
+ require Exporter;
+
+ $self->SUPER::import(@a); # need it for subclasses
+ $self->export_to_level(1,$self,@a); # need it for MBF
+ }
+
+ # try to load core math lib
+ my @c = split /\s*,\s*/,$CALC;
+ foreach (@c)
+ {
+ $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
+ }
+ push @c, \'FastCalc', \'Calc' # if all fail, try these
+ if $warn_or_die < 2; # but not for "only"
+ $CALC = ''; # signal error
+ foreach my $l (@c)
+ {
+ # fallback libraries are "marked" as \'string', extract string if nec.
+ my $lib = $l; $lib = $$l if ref($l);
+
+ next if ($lib || '') eq '';
+ $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i;
+ $lib =~ s/\.pm$//;
+ if ($] < 5.006)
+ {
+ # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is
+ # used in the same script, or eval("") inside import().
+ my @parts = split /::/, $lib; # Math::BigInt => Math BigInt
+ my $file = pop @parts; $file .= '.pm'; # BigInt => BigInt.pm
+ require File::Spec;
+ $file = File::Spec->catfile (@parts, $file);
+ eval { require "$file"; $lib->import( @c ); }
+ }
+ else
+ {
+ eval "use $lib qw/@c/;";
+ }
+ if ($@ eq '')
+ {
+ my $ok = 1;
+ # loaded it ok, see if the api_version() is high enough
+ if ($lib->can('api_version') && $lib->api_version() >= 1.0)
+ {
+ $ok = 0;
+ # api_version matches, check if it really provides anything we need
+ for my $method (qw/
+ one two ten
+ str num
+ add mul div sub dec inc
+ acmp len digit is_one is_zero is_even is_odd
+ is_two is_ten
+ zeros new copy check
+ from_hex from_oct from_bin as_hex as_bin as_oct
+ rsft lsft xor and or
+ mod sqrt root fac pow modinv modpow log_int gcd
+ /)
+ {
+ if (!$lib->can("_$method"))
+ {
+ if (($WARN{$lib}||0) < 2)
+ {
+ require Carp;
+ Carp::carp ("$lib is missing method '_$method'");
+ $WARN{$lib} = 1; # still warn about the lib
+ }
+ $ok++; last;
+ }
+ }
+ }
+ if ($ok == 0)
+ {
+ $CALC = $lib;
+ if ($warn_or_die > 0 && ref($l))
+ {
+ require Carp;
+ my $msg = "Math::BigInt: couldn't load specified math lib(s), fallback to $lib";
+ Carp::carp ($msg) if $warn_or_die == 1;
+ Carp::croak ($msg) if $warn_or_die == 2;
+ }
+ last; # found a usable one, break
+ }
+ else
+ {
+ if (($WARN{$lib}||0) < 2)
+ {
+ my $ver = eval "\$$lib\::VERSION" || 'unknown';
+ require Carp;
+ Carp::carp ("Cannot load outdated $lib v$ver, please upgrade");
+ $WARN{$lib} = 2; # never warn again
+ }
+ }
+ }
+ }
+ if ($CALC eq '')
+ {
+ require Carp;
+ if ($warn_or_die == 2)
+ {
+ Carp::croak ("Couldn't load specified math lib(s) and fallback disallowed");
+ }
+ else
+ {
+ Carp::croak ("Couldn't load any math lib(s), not even fallback to Calc.pm");
+ }
+ }
+
+ # notify callbacks
+ foreach my $class (keys %CALLBACKS)
+ {
+ &{$CALLBACKS{$class}}($CALC);
+ }
+
+ # Fill $CAN with the results of $CALC->can(...) for emulating lower math lib
+ # functions
+
+ %CAN = ();
+ for my $method (qw/ signed_and signed_or signed_xor /)
+ {
+ $CAN{$method} = $CALC->can("_$method") ? 1 : 0;
+ }
+
+ # import done
+ }
+
+sub from_hex
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $hs) = @_;
+
+ my $rc = __from_hex($hs);
+
+ return $self->bnan() unless defined $rc;
+
+ $rc;
+ }
+
+sub from_bin
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $bs) = @_;
+
+ my $rc = __from_bin($bs);
+
+ return $self->bnan() unless defined $rc;
+
+ $rc;
+ }
+
+sub from_oct
+ {
+ # create a bigint from a hexadecimal string
+ my ($self, $os) = @_;
+
+ my $x = $self->bzero();
+
+ # strip underscores
+ $os =~ s/([0-7])_([0-7])/$1$2/g;
+ $os =~ s/([0-7])_([0-7])/$1$2/g;
+
+ return $x->bnan() if $os !~ /^[\-\+]?0[0-7]+\z/;
+
+ my $sign = '+'; $sign = '-' if $os =~ /^-/;
+
+ $os =~ s/^[+-]//; # strip sign
+ $x->{value} = $CALC->_from_oct($os);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub __from_hex
+ {
+ # internal
+ # convert a (ref to) big hex string to BigInt, return undef for error
+ my $hs = shift;
+
+ my $x = Math::BigInt->bzero();
+
+ # strip underscores
+ $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
+ $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
+
+ return $x->bnan() if $hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/;
+
+ my $sign = '+'; $sign = '-' if $hs =~ /^-/;
+
+ $hs =~ s/^[+-]//; # strip sign
+ $x->{value} = $CALC->_from_hex($hs);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub __from_bin
+ {
+ # internal
+ # convert a (ref to) big binary string to BigInt, return undef for error
+ my $bs = shift;
+
+ my $x = Math::BigInt->bzero();
+
+ # strip underscores
+ $bs =~ s/([01])_([01])/$1$2/g;
+ $bs =~ s/([01])_([01])/$1$2/g;
+ return $x->bnan() if $bs !~ /^[+-]?0b[01]+$/;
+
+ my $sign = '+'; $sign = '-' if $bs =~ /^\-/;
+ $bs =~ s/^[+-]//; # strip sign
+
+ $x->{value} = $CALC->_from_bin($bs);
+ $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
+ $x;
+ }
+
+sub _split
+ {
+ # input: num_str; output: undef for invalid or
+ # (\$mantissa_sign,\$mantissa_value,\$mantissa_fraction,\$exp_sign,\$exp_value)
+ # Internal, take apart a string and return the pieces.
+ # Strip leading/trailing whitespace, leading zeros, underscore and reject
+ # invalid input.
+ my $x = shift;
+
+ # strip white space at front, also extranous leading zeros
+ $x =~ s/^\s*([-]?)0*([0-9])/$1$2/g; # will not strip ' .2'
+ $x =~ s/^\s+//; # but this will
+ $x =~ s/\s+$//g; # strip white space at end
+
+ # shortcut, if nothing to split, return early
+ if ($x =~ /^[+-]?[0-9]+\z/)
+ {
+ $x =~ s/^([+-])0*([0-9])/$2/; my $sign = $1 || '+';
+ return (\$sign, \$x, \'', \'', \0);
+ }
+
+ # invalid starting char?
+ return if $x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/;
+
+ return __from_hex($x) if $x =~ /^[\-\+]?0x/; # hex string
+ return __from_bin($x) if $x =~ /^[\-\+]?0b/; # binary string
+
+ # strip underscores between digits
+ $x =~ s/([0-9])_([0-9])/$1$2/g;
+ $x =~ s/([0-9])_([0-9])/$1$2/g; # do twice for 1_2_3
+
+ # some possible inputs:
+ # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2
+ # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2 # 0e999
+
+ my ($m,$e,$last) = split /[Ee]/,$x;
+ return if defined $last; # last defined => 1e2E3 or others
+ $e = '0' if !defined $e || $e eq "";
+
+ # sign,value for exponent,mantint,mantfrac
+ my ($es,$ev,$mis,$miv,$mfv);
+ # valid exponent?
+ if ($e =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
+ {
+ $es = $1; $ev = $2;
+ # valid mantissa?
+ return if $m eq '.' || $m eq '';
+ my ($mi,$mf,$lastf) = split /\./,$m;
+ return if defined $lastf; # lastf defined => 1.2.3 or others
+ $mi = '0' if !defined $mi;
+ $mi .= '0' if $mi =~ /^[\-\+]?$/;
+ $mf = '0' if !defined $mf || $mf eq '';
+ if ($mi =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
+ {
+ $mis = $1||'+'; $miv = $2;
+ return unless ($mf =~ /^([0-9]*?)0*$/); # strip trailing zeros
+ $mfv = $1;
+ # handle the 0e999 case here
+ $ev = 0 if $miv eq '0' && $mfv eq '';
+ return (\$mis,\$miv,\$mfv,\$es,\$ev);
+ }
+ }
+ return; # NaN, not a number
+ }
+
+##############################################################################
+# internal calculation routines (others are in Math::BigInt::Calc etc)
+
+sub __lcm
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does modify first argument
+ # LCM
+
+ my ($x,$ty) = @_;
+ return $x->bnan() if ($x->{sign} eq $nan) || ($ty->{sign} eq $nan);
+ my $method = ref($x) . '::bgcd';
+ no strict 'refs';
+ $x * $ty / &$method($x,$ty);
+ }
+
+###############################################################################
+# trigonometric functions
+
+sub bpi
+ {
+ # Calculate PI to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer, that is, always returns '3'.
+ my ($self,$n) = @_;
+ if (@_ == 1)
+ {
+ # called like Math::BigInt::bpi(10);
+ $n = $self; $self = $class;
+ }
+ $self = ref($self) if ref($self);
+
+ return $upgrade->new($n) if defined $upgrade;
+
+ # hard-wired to "3"
+ $self->new(3);
+ }
+
+sub bcos
+ {
+ # Calculate cosinus(x) to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bcos');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->bcos(@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->bcos(@r)->as_int();
+
+ $x->bone() if $t->is_one();
+ $x->bzero() if $t->is_zero();
+ $x->round(@r);
+ }
+
+sub bsin
+ {
+ # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('bsin');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->bsin(@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->bsin(@r)->as_int();
+
+ $x->bone() if $t->is_one();
+ $x->bzero() if $t->is_zero();
+ $x->round(@r);
+ }
+
+sub batan2
+ {
+ # calculate arcus tangens of ($y/$x)
+
+ # set up parameters
+ my ($self,$y,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$y,$x,@r) = objectify(2,@_);
+ }
+
+ return $y if $y->modify('batan2');
+
+ return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
+
+ # Y X
+ # != 0 -inf result is +- pi
+ if ($x->is_inf() || $y->is_inf())
+ {
+ # upgrade to BigFloat etc.
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+ if ($y->is_inf())
+ {
+ if ($x->{sign} eq '-inf')
+ {
+ # calculate 3 pi/4 => 2.3.. => 2
+ $y->bone( substr($y->{sign},0,1) );
+ $y->bmul($self->new(2));
+ }
+ elsif ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4 => 0.7 => 0
+ $y->bzero();
+ }
+ else
+ {
+ # calculate pi/2 => 1.5 => 1
+ $y->bone( substr($y->{sign},0,1) );
+ }
+ }
+ else
+ {
+ if ($x->{sign} eq '+inf')
+ {
+ # calculate pi/4 => 0.7 => 0
+ $y->bzero();
+ }
+ else
+ {
+ # PI => 3.1415.. => 3
+ $y->bone( substr($y->{sign},0,1) );
+ $y->bmul($self->new(3));
+ }
+ }
+ return $y;
+ }
+
+ return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
+
+ require Math::BigFloat;
+ my $r = Math::BigFloat->new($y)->batan2(Math::BigFloat->new($x),@r)->as_int();
+
+ $x->{value} = $r->{value};
+ $x->{sign} = $r->{sign};
+
+ $x;
+ }
+
+sub batan
+ {
+ # Calculate arcus tangens of x to N digits. Unless upgrading is in effect, returns the
+ # result truncated to an integer.
+ my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
+
+ return $x if $x->modify('batan');
+
+ return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
+
+ return $upgrade->new($x)->batan(@r) if defined $upgrade;
+
+ # calculate the result and truncate it to integer
+ my $t = Math::BigFloat->new($x)->batan(@r);
+
+ $x->{value} = $CALC->_new( $x->as_int()->bstr() );
+ $x->round(@r);
+ }
+
+###############################################################################
+# this method returns 0 if the object can be modified, or 1 if not.
+# We use a fast constant sub() here, to avoid costly calls. Subclasses
+# may override it with special code (f.i. Math::BigInt::Constant does so)
+
+sub modify () { 0; }
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Math::BigInt - Arbitrary size integer/float math package
+
+=head1 SYNOPSIS
+
+ use Math::BigInt;
+
+ # or make it faster with huge numbers: install (optional)
+ # Math::BigInt::GMP and always use (it will fall back to
+ # pure Perl if the GMP library is not installed):
+ # (See also the L<MATH LIBRARY> section!)
+
+ # will warn if Math::BigInt::GMP cannot be found
+ use Math::BigInt lib => 'GMP';
+
+ # to supress the warning use this:
+ # use Math::BigInt try => 'GMP';
+
+ # dies if GMP cannot be loaded:
+ # use Math::BigInt only => 'GMP';
+
+ my $str = '1234567890';
+ my @values = (64,74,18);
+ my $n = 1; my $sign = '-';
+
+ # Number creation
+ my $x = Math::BigInt->new($str); # defaults to 0
+ my $y = $x->copy(); # make a true copy
+ my $nan = Math::BigInt->bnan(); # create a NotANumber
+ my $zero = Math::BigInt->bzero(); # create a +0
+ my $inf = Math::BigInt->binf(); # create a +inf
+ my $inf = Math::BigInt->binf('-'); # create a -inf
+ my $one = Math::BigInt->bone(); # create a +1
+ my $mone = Math::BigInt->bone('-'); # create a -1
+
+ my $pi = Math::BigInt->bpi(); # returns '3'
+ # see Math::BigFloat::bpi()
+
+ $h = Math::BigInt->new('0x123'); # from hexadecimal
+ $b = Math::BigInt->new('0b101'); # from binary
+ $o = Math::BigInt->from_oct('0101'); # from octal
+
+ # Testing (don't modify their arguments)
+ # (return true if the condition is met, otherwise false)
+
+ $x->is_zero(); # if $x is +0
+ $x->is_nan(); # if $x is NaN
+ $x->is_one(); # if $x is +1
+ $x->is_one('-'); # if $x is -1
+ $x->is_odd(); # if $x is odd
+ $x->is_even(); # if $x is even
+ $x->is_pos(); # if $x >= 0
+ $x->is_neg(); # if $x < 0
+ $x->is_inf($sign); # if $x is +inf, or -inf (sign is default '+')
+ $x->is_int(); # if $x is an integer (not a float)
+
+ # comparing and digit/sign extraction
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+ $x->digit($n); # return the nth digit, counting from right
+ $x->digit(-$n); # return the nth digit, counting from left
+
+ # The following all modify their first argument. If you want to preserve
+ # $x, use $z = $x->copy()->bXXX($y); See under L<CAVEATS> for why this is
+ # necessary when mixing $a = $b assignments with non-overloaded math.
+
+ $x->bzero(); # set $x to 0
+ $x->bnan(); # set $x to NaN
+ $x->bone(); # set $x to +1
+ $x->bone('-'); # set $x to -1
+ $x->binf(); # set $x to inf
+ $x->binf('-'); # set $x to -inf
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op in BigInt)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment $x by 1
+ $x->bdec(); # decrement $x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmuladd($y,$z); # $x = $x * $y + $z
+
+ $x->bmod($y); # modulus (x % y)
+ $x->bmodpow($exp,$mod); # modular exponentation (($num**$exp) % $mod))
+ $x->bmodinv($mod); # the inverse of $x in the given modulus $mod
+
+ $x->bpow($y); # power of arguments (x ** y)
+ $x->blsft($y); # left shift in base 2
+ $x->brsft($y); # right shift in base 2
+ # returns (quo,rem) or quo if in scalar context
+ $x->blsft($y,$n); # left shift by $y places in base $n
+ $x->brsft($y,$n); # right shift by $y places in base $n
+ # returns (quo,rem) or quo if in scalar context
+
+ $x->band($y); # bitwise and
+ $x->bior($y); # bitwise inclusive or
+ $x->bxor($y); # bitwise exclusive or
+ $x->bnot(); # bitwise not (two's complement)
+
+ $x->bsqrt(); # calculate square-root
+ $x->broot($y); # $y'th root of $x (e.g. $y == 3 => cubic root)
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+ $x->blog(); # logarithm of $x to base e (Euler's number)
+ $x->blog($base); # logarithm of $x to base $base (f.i. 2)
+ $x->bexp(); # calculate e ** $x where e is Euler's number
+
+ $x->round($A,$P,$mode); # round to accuracy or precision using mode $mode
+ $x->bround($n); # accuracy: preserve $n digits
+ $x->bfround($n); # $n > 0: round $nth digits,
+ # $n < 0: round to the $nth digit after the
+ # dot, no-op for BigInts
+
+ # The following do not modify their arguments in BigInt (are no-ops),
+ # but do so in BigFloat:
+
+ $x->bfloor(); # return integer less or equal than $x
+ $x->bceil(); # return integer greater or equal than $x
+
+ # The following do not modify their arguments:
+
+ # greatest common divisor (no OO style)
+ my $gcd = Math::BigInt::bgcd(@values);
+ # lowest common multiplicator (no OO style)
+ my $lcm = Math::BigInt::blcm(@values);
+
+ $x->length(); # return number of digits in number
+ ($xl,$f) = $x->length(); # length of number and length of fraction part,
+ # latter is always 0 digits long for BigInts
+
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return (signed) mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+ $x->copy(); # make a true copy of $x (unlike $y = $x;)
+ $x->as_int(); # return as BigInt (in BigInt: same as copy())
+ $x->numify(); # return as scalar (might overflow!)
+
+ # conversation to string (do not modify their argument)
+ $x->bstr(); # normalized string (e.g. '3')
+ $x->bsstr(); # norm. string in scientific notation (e.g. '3E0')
+ $x->as_hex(); # as signed hexadecimal string with prefixed 0x
+ $x->as_bin(); # as signed binary string with prefixed 0b
+ $x->as_oct(); # as signed octal string with prefixed 0
+
+
+ # precision and accuracy (see section about rounding for more)
+ $x->precision(); # return P of $x (or global, if P of $x undef)
+ $x->precision($n); # set P of $x to $n
+ $x->accuracy(); # return A of $x (or global, if A of $x undef)
+ $x->accuracy($n); # set A $x to $n
+
+ # Global methods
+ Math::BigInt->precision(); # get/set global P for all BigInt objects
+ Math::BigInt->accuracy(); # get/set global A for all BigInt objects
+ Math::BigInt->round_mode(); # get/set global round mode, one of
+ # 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
+ Math::BigInt->config(); # return hash containing configuration
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded if you
+declare your big integers as
+
+ $i = new Math::BigInt '123_456_789_123_456_789';
+
+Operations with overloaded operators preserve the arguments which is
+exactly what you expect.
+
+=over 2
+
+=item Input
+
+Input values to these routines may be any string, that looks like a number
+and results in an integer, including hexadecimal and binary numbers.
+
+Scalars holding numbers may also be passed, but note that non-integer numbers
+may already have lost precision due to the conversation to float. Quote
+your input if you want BigInt to see all the digits:
+
+ $x = Math::BigInt->new(12345678890123456789); # bad
+ $x = Math::BigInt->new('12345678901234567890'); # good
+
+You can include one underscore between any two digits.
+
+This means integer values like 1.01E2 or even 1000E-2 are also accepted.
+Non-integer values result in NaN.
+
+Hexadecimal (prefixed with "0x") and binary numbers (prefixed with "0b")
+are accepted, too. Please note that octal numbers are not recognized
+by new(), so the following will print "123":
+
+ perl -MMath::BigInt -le 'print Math::BigInt->new("0123")'
+
+To convert an octal number, use from_oct();
+
+ perl -MMath::BigInt -le 'print Math::BigInt->from_oct("0123")'
+
+Currently, Math::BigInt::new() defaults to 0, while Math::BigInt::new('')
+results in 'NaN'. This might change in the future, so use always the following
+explicit forms to get a zero or NaN:
+
+ $zero = Math::BigInt->bzero();
+ $nan = Math::BigInt->bnan();
+
+C<bnorm()> on a BigInt object is now effectively a no-op, since the numbers
+are always stored in normalized form. If passed a string, creates a BigInt
+object from the input.
+
+=item Output
+
+Output values are BigInt objects (normalized), except for the methods which
+return a string (see L<SYNOPSIS>).
+
+Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
+C<is_nan()>, etc.) return true or false, while others (C<bcmp()>, C<bacmp()>)
+return either undef (if NaN is involved), <0, 0 or >0 and are suited for sort.
+
+=back
+
+=head1 METHODS
+
+Each of the methods below (except config(), accuracy() and precision())
+accepts three additional parameters. These arguments C<$A>, C<$P> and C<$R>
+are C<accuracy>, C<precision> and C<round_mode>. Please see the section about
+L<ACCURACY and PRECISION> for more information.
+
+=head2 config()
+
+ use Data::Dumper;
+
+ print Dumper ( Math::BigInt->config() );
+ print Math::BigInt->config()->{lib},"\n";
+
+Returns a hash containing the configuration, e.g. the version number, lib
+loaded etc. The following hash keys are currently filled in with the
+appropriate information.
+
+ key Description
+ Example
+ ============================================================
+ lib Name of the low-level math library
+ Math::BigInt::Calc
+ lib_version Version of low-level math library (see 'lib')
+ 0.30
+ class The class name of config() you just called
+ Math::BigInt
+ upgrade To which class math operations might be upgraded
+ Math::BigFloat
+ downgrade To which class math operations might be downgraded
+ undef
+ precision Global precision
+ undef
+ accuracy Global accuracy
+ undef
+ round_mode Global round mode
+ even
+ version version number of the class you used
+ 1.61
+ div_scale Fallback accuracy for div
+ 40
+ trap_nan If true, traps creation of NaN via croak()
+ 1
+ trap_inf If true, traps creation of +inf/-inf via croak()
+ 1
+
+The following values can be set by passing C<config()> a reference to a hash:
+
+ trap_inf trap_nan
+ upgrade downgrade precision accuracy round_mode div_scale
+
+Example:
+
+ $new_cfg = Math::BigInt->config( { trap_inf => 1, precision => 5 } );
+
+=head2 accuracy()
+
+ $x->accuracy(5); # local for $x
+ CLASS->accuracy(5); # global for all members of CLASS
+ # Note: This also applies to new()!
+
+ $A = $x->accuracy(); # read out accuracy that affects $x
+ $A = CLASS->accuracy(); # read out global accuracy
+
+Set or get the global or local accuracy, aka how many significant digits the
+results have. If you set a global accuracy, then this also applies to new()!
+
+Warning! The accuracy I<sticks>, e.g. once you created a number under the
+influence of C<< CLASS->accuracy($A) >>, all results from math operations with
+that number will also be rounded.
+
+In most cases, you should probably round the results explicitly using one of
+L<round()>, L<bround()> or L<bfround()> or by passing the desired accuracy
+to the math operation as additional parameter:
+
+ my $x = Math::BigInt->new(30000);
+ my $y = Math::BigInt->new(7);
+ print scalar $x->copy()->bdiv($y, 2); # print 4300
+ print scalar $x->copy()->bdiv($y)->bround(2); # print 4300
+
+Please see the section about L<ACCURACY AND PRECISION> for further details.
+
+Value must be greater than zero. Pass an undef value to disable it:
+
+ $x->accuracy(undef);
+ Math::BigInt->accuracy(undef);
+
+Returns the current accuracy. For C<$x->accuracy()> it will return either the
+local accuracy, or if not defined, the global. This means the return value
+represents the accuracy that will be in effect for $x:
+
+ $y = Math::BigInt->new(1234567); # unrounded
+ print Math::BigInt->accuracy(4),"\n"; # set 4, print 4
+ $x = Math::BigInt->new(123456); # $x will be automatically rounded!
+ print "$x $y\n"; # '123500 1234567'
+ print $x->accuracy(),"\n"; # will be 4
+ print $y->accuracy(),"\n"; # also 4, since global is 4
+ print Math::BigInt->accuracy(5),"\n"; # set to 5, print 5
+ print $x->accuracy(),"\n"; # still 4
+ print $y->accuracy(),"\n"; # 5, since global is 5
+
+Note: Works also for subclasses like Math::BigFloat. Each class has it's own
+globals separated from Math::BigInt, but it is possible to subclass
+Math::BigInt and make the globals of the subclass aliases to the ones from
+Math::BigInt.
+
+=head2 precision()
+
+ $x->precision(-2); # local for $x, round at the second digit right of the dot
+ $x->precision(2); # ditto, round at the second digit left of the dot
+
+ CLASS->precision(5); # Global for all members of CLASS
+ # This also applies to new()!
+ CLASS->precision(-5); # ditto
+
+ $P = CLASS->precision(); # read out global precision
+ $P = $x->precision(); # read out precision that affects $x
+
+Note: You probably want to use L<accuracy()> instead. With L<accuracy> you
+set the number of digits each result should have, with L<precision> you
+set the place where to round!
+
+C<precision()> sets or gets the global or local precision, aka at which digit
+before or after the dot to round all results. A set global precision also
+applies to all newly created numbers!
+
+In Math::BigInt, passing a negative number precision has no effect since no
+numbers have digits after the dot. In L<Math::BigFloat>, it will round all
+results to P digits after the dot.
+
+Please see the section about L<ACCURACY AND PRECISION> for further details.
+
+Pass an undef value to disable it:
+
+ $x->precision(undef);
+ Math::BigInt->precision(undef);
+
+Returns the current precision. For C<$x->precision()> it will return either the
+local precision of $x, or if not defined, the global. This means the return
+value represents the prevision that will be in effect for $x:
+
+ $y = Math::BigInt->new(1234567); # unrounded
+ print Math::BigInt->precision(4),"\n"; # set 4, print 4
+ $x = Math::BigInt->new(123456); # will be automatically rounded
+ print $x; # print "120000"!
+
+Note: Works also for subclasses like L<Math::BigFloat>. Each class has its
+own globals separated from Math::BigInt, but it is possible to subclass
+Math::BigInt and make the globals of the subclass aliases to the ones from
+Math::BigInt.
+
+=head2 brsft()
+
+ $x->brsft($y,$n);
+
+Shifts $x right by $y in base $n. Default is base 2, used are usually 10 and
+2, but others work, too.
+
+Right shifting usually amounts to dividing $x by $n ** $y and truncating the
+result:
+
+
+ $x = Math::BigInt->new(10);
+ $x->brsft(1); # same as $x >> 1: 5
+ $x = Math::BigInt->new(1234);
+ $x->brsft(2,10); # result 12
+
+There is one exception, and that is base 2 with negative $x:
+
+
+ $x = Math::BigInt->new(-5);
+ print $x->brsft(1);
+
+This will print -3, not -2 (as it would if you divide -5 by 2 and truncate the
+result).
+
+=head2 new()
+
+ $x = Math::BigInt->new($str,$A,$P,$R);
+
+Creates a new BigInt object from a scalar or another BigInt object. The
+input is accepted as decimal, hex (with leading '0x') or binary (with leading
+'0b').
+
+See L<Input> for more info on accepted input formats.
+
+=head2 from_oct()
+
+ $x = Math::BigInt->from_oct("0775"); # input is octal
+
+=head2 from_hex()
+
+ $x = Math::BigInt->from_hex("0xcafe"); # input is hexadecimal
+
+=head2 from_bin()
+
+ $x = Math::BigInt->from_oct("0x10011"); # input is binary
+
+=head2 bnan()
+
+ $x = Math::BigInt->bnan();
+
+Creates a new BigInt object representing NaN (Not A Number).
+If used on an object, it will set it to NaN:
+
+ $x->bnan();
+
+=head2 bzero()
+
+ $x = Math::BigInt->bzero();
+
+Creates a new BigInt object representing zero.
+If used on an object, it will set it to zero:
+
+ $x->bzero();
+
+=head2 binf()
+
+ $x = Math::BigInt->binf($sign);
+
+Creates a new BigInt object representing infinity. The optional argument is
+either '-' or '+', indicating whether you want infinity or minus infinity.
+If used on an object, it will set it to infinity:
+
+ $x->binf();
+ $x->binf('-');
+
+=head2 bone()
+
+ $x = Math::BigInt->binf($sign);
+
+Creates a new BigInt object representing one. The optional argument is
+either '-' or '+', indicating whether you want one or minus one.
+If used on an object, it will set it to one:
+
+ $x->bone(); # +1
+ $x->bone('-'); # -1
+
+=head2 is_one()/is_zero()/is_nan()/is_inf()
+
+
+ $x->is_zero(); # true if arg is +0
+ $x->is_nan(); # true if arg is NaN
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_inf(); # true if +inf
+ $x->is_inf('-'); # true if -inf (sign is default '+')
+
+These methods all test the BigInt for being one specific value and return
+true or false depending on the input. These are faster than doing something
+like:
+
+ if ($x == 0)
+
+=head2 is_pos()/is_neg()/is_positive()/is_negative()
+
+ $x->is_pos(); # true if > 0
+ $x->is_neg(); # true if < 0
+
+The methods return true if the argument is positive or negative, respectively.
+C<NaN> is neither positive nor negative, while C<+inf> counts as positive, and
+C<-inf> is negative. A C<zero> is neither positive nor negative.
+
+These methods are only testing the sign, and not the value.
+
+C<is_positive()> and C<is_negative()> are aliases to C<is_pos()> and
+C<is_neg()>, respectively. C<is_positive()> and C<is_negative()> were
+introduced in v1.36, while C<is_pos()> and C<is_neg()> were only introduced
+in v1.68.
+
+=head2 is_odd()/is_even()/is_int()
+
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_int(); # true if $x is an integer
+
+The return true when the argument satisfies the condition. C<NaN>, C<+inf>,
+C<-inf> are not integers and are neither odd nor even.
+
+In BigInt, all numbers except C<NaN>, C<+inf> and C<-inf> are integers.
+
+=head2 bcmp()
+
+ $x->bcmp($y);
+
+Compares $x with $y and takes the sign into account.
+Returns -1, 0, 1 or undef.
+
+=head2 bacmp()
+
+ $x->bacmp($y);
+
+Compares $x with $y while ignoring their. Returns -1, 0, 1 or undef.
+
+=head2 sign()
+
+ $x->sign();
+
+Return the sign, of $x, meaning either C<+>, C<->, C<-inf>, C<+inf> or NaN.
+
+If you want $x to have a certain sign, use one of the following methods:
+
+ $x->babs(); # '+'
+ $x->babs()->bneg(); # '-'
+ $x->bnan(); # 'NaN'
+ $x->binf(); # '+inf'
+ $x->binf('-'); # '-inf'
+
+=head2 digit()
+
+ $x->digit($n); # return the nth digit, counting from right
+
+If C<$n> is negative, returns the digit counting from left.
+
+=head2 bneg()
+
+ $x->bneg();
+
+Negate the number, e.g. change the sign between '+' and '-', or between '+inf'
+and '-inf', respectively. Does nothing for NaN or zero.
+
+=head2 babs()
+
+ $x->babs();
+
+Set the number to its absolute value, e.g. change the sign from '-' to '+'
+and from '-inf' to '+inf', respectively. Does nothing for NaN or positive
+numbers.
+
+=head2 bnorm()
+
+ $x->bnorm(); # normalize (no-op)
+
+=head2 bnot()
+
+ $x->bnot();
+
+Two's complement (bitwise not). This is equivalent to
+
+ $x->binc()->bneg();
+
+but faster.
+
+=head2 binc()
+
+ $x->binc(); # increment x by 1
+
+=head2 bdec()
+
+ $x->bdec(); # decrement x by 1
+
+=head2 badd()
+
+ $x->badd($y); # addition (add $y to $x)
+
+=head2 bsub()
+
+ $x->bsub($y); # subtraction (subtract $y from $x)
+
+=head2 bmul()
+
+ $x->bmul($y); # multiplication (multiply $x by $y)
+
+=head2 bmuladd()
+
+ $x->bmuladd($y,$z);
+
+Multiply $x by $y, and then add $z to the result,
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bdiv()
+
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+=head2 bmod()
+
+ $x->bmod($y); # modulus (x % y)
+
+=head2 bmodinv()
+
+ num->bmodinv($mod); # modular inverse
+
+Returns the inverse of C<$num> in the given modulus C<$mod>. 'C<NaN>' is
+returned unless C<$num> is relatively prime to C<$mod>, i.e. unless
+C<bgcd($num, $mod)==1>.
+
+=head2 bmodpow()
+
+ $num->bmodpow($exp,$mod); # modular exponentation
+ # ($num**$exp % $mod)
+
+Returns the value of C<$num> taken to the power C<$exp> in the modulus
+C<$mod> using binary exponentation. C<bmodpow> is far superior to
+writing
+
+ $num ** $exp % $mod
+
+because it is much faster - it reduces internal variables into
+the modulus whenever possible, so it operates on smaller numbers.
+
+C<bmodpow> also supports negative exponents.
+
+ bmodpow($num, -1, $mod)
+
+is exactly equivalent to
+
+ bmodinv($num, $mod)
+
+=head2 bpow()
+
+ $x->bpow($y); # power of arguments (x ** y)
+
+=head2 blog()
+
+ $x->blog($base, $accuracy); # logarithm of x to the base $base
+
+If C<$base> is not defined, Euler's number (e) is used:
+
+ print $x->blog(undef, 100); # log(x) to 100 digits
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates the expression C<e ** $x> where C<e> is Euler's number.
+
+This method was added in v1.82 of Math::BigInt (April 2007).
+
+See also L<blog()>.
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v1.84 of Math::BigInt (April 2007).
+
+=head2 bpi()
+
+ print Math::BigInt->bpi(100), "\n"; # 3
+
+Returns PI truncated to an integer, with the argument being ignored. This means
+under BigInt this always returns C<3>.
+
+If upgrading is in effect, returns PI, rounded to N digits with the
+current rounding mode:
+
+ use Math::BigFloat;
+ use Math::BigInt upgrade => Math::BigFloat;
+ print Math::BigInt->bpi(3), "\n"; # 3.14
+ print Math::BigInt->bpi(100), "\n"; # 3.1415....
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bcos()
+
+ my $x = Math::BigInt->new(1);
+ print $x->bcos(100), "\n";
+
+Calculate the cosinus of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 bsin()
+
+ my $x = Math::BigInt->new(1);
+ print $x->bsin(100), "\n";
+
+Calculate the sinus of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan2()
+
+ my $x = Math::BigInt->new(1);
+ my $y = Math::BigInt->new(1);
+ print $y->batan2($x), "\n";
+
+Calculate the arcus tangens of C<$y> divided by C<$x>, modifying $y in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 batan()
+
+ my $x = Math::BigFloat->new(0.5);
+ print $x->batan(100), "\n";
+
+Calculate the arcus tangens of $x, modifying $x in place.
+
+In BigInt, unless upgrading is in effect, the result is truncated to an
+integer.
+
+This method was added in v1.87 of Math::BigInt (June 2007).
+
+=head2 blsft()
+
+ $x->blsft($y); # left shift in base 2
+ $x->blsft($y,$n); # left shift, in base $n (like 10)
+
+=head2 brsft()
+
+ $x->brsft($y); # right shift in base 2
+ $x->brsft($y,$n); # right shift, in base $n (like 10)
+
+=head2 band()
+
+ $x->band($y); # bitwise and
+
+=head2 bior()
+
+ $x->bior($y); # bitwise inclusive or
+
+=head2 bxor()
+
+ $x->bxor($y); # bitwise exclusive or
+
+=head2 bnot()
+
+ $x->bnot(); # bitwise not (two's complement)
+
+=head2 bsqrt()
+
+ $x->bsqrt(); # calculate square-root
+
+=head2 broot()
+
+ $x->broot($N);
+
+Calculates the N'th root of C<$x>.
+
+=head2 bfac()
+
+ $x->bfac(); # factorial of $x (1*2*3*4*..$x)
+
+=head2 round()
+
+ $x->round($A,$P,$round_mode);
+
+Round $x to accuracy C<$A> or precision C<$P> using the round mode
+C<$round_mode>.
+
+=head2 bround()
+
+ $x->bround($N); # accuracy: preserve $N digits
+
+=head2 bfround()
+
+ $x->bfround($N);
+
+If N is > 0, rounds to the Nth digit from the left. If N < 0, rounds to
+the Nth digit after the dot. Since BigInts are integers, the case N < 0
+is a no-op for them.
+
+Examples:
+
+ Input N Result
+ ===================================================
+ 123456.123456 3 123500
+ 123456.123456 2 123450
+ 123456.123456 -2 123456.12
+ 123456.123456 -3 123456.123
+
+=head2 bfloor()
+
+ $x->bfloor();
+
+Set $x to the integer less or equal than $x. This is a no-op in BigInt, but
+does change $x in BigFloat.
+
+=head2 bceil()
+
+ $x->bceil();
+
+Set $x to the integer greater or equal than $x. This is a no-op in BigInt, but
+does change $x in BigFloat.
+
+=head2 bgcd()
+
+ bgcd(@values); # greatest common divisor (no OO style)
+
+=head2 blcm()
+
+ blcm(@values); # lowest common multiplicator (no OO style)
+
+head2 length()
+
+ $x->length();
+ ($xl,$fl) = $x->length();
+
+Returns the number of digits in the decimal representation of the number.
+In list context, returns the length of the integer and fraction part. For
+BigInt's, the length of the fraction part will always be 0.
+
+=head2 exponent()
+
+ $x->exponent();
+
+Return the exponent of $x as BigInt.
+
+=head2 mantissa()
+
+ $x->mantissa();
+
+Return the signed mantissa of $x as BigInt.
+
+=head2 parts()
+
+ $x->parts(); # return (mantissa,exponent) as BigInt
+
+=head2 copy()
+
+ $x->copy(); # make a true copy of $x (unlike $y = $x;)
+
+=head2 as_int()/as_number()
+
+ $x->as_int();
+
+Returns $x as a BigInt (truncated towards zero). In BigInt this is the same as
+C<copy()>.
+
+C<as_number()> is an alias to this method. C<as_number> was introduced in
+v1.22, while C<as_int()> was only introduced in v1.68.
+
+=head2 bstr()
+
+ $x->bstr();
+
+Returns a normalized string representation of C<$x>.
+
+=head2 bsstr()
+
+ $x->bsstr(); # normalized string in scientific notation
+
+=head2 as_hex()
+
+ $x->as_hex(); # as signed hexadecimal string with prefixed 0x
+
+=head2 as_bin()
+
+ $x->as_bin(); # as signed binary string with prefixed 0b
+
+=head2 as_oct()
+
+ $x->as_oct(); # as signed octal string with prefixed 0
+
+=head2 numify()
+
+ print $x->numify();
+
+This returns a normal Perl scalar from $x. It is used automatically
+whenever a scalar is needed, for instance in array index operations.
+
+This loses precision, to avoid this use L<as_int()> instead.
+
+=head2 modify()
+
+ $x->modify('bpowd');
+
+This method returns 0 if the object can be modified with the given
+peration, or 1 if not.
+
+This is used for instance by L<Math::BigInt::Constant>.
+
+=head2 upgrade()/downgrade()
+
+Set/get the class for downgrade/upgrade operations. Thuis is used
+for instance by L<bignum>. The defaults are '', thus the following
+operation will create a BigInt, not a BigFloat:
+
+ my $i = Math::BigInt->new(123);
+ my $f = Math::BigFloat->new('123.1');
+
+ print $i + $f,"\n"; # print 246
+
+=head2 div_scale()
+
+Set/get the number of digits for the default precision in divide
+operations.
+
+=head2 round_mode()
+
+Set/get the current round mode.
+
+=head1 ACCURACY and PRECISION
+
+Since version v1.33, Math::BigInt and Math::BigFloat have full support for
+accuracy and precision based rounding, both automatically after every
+operation, as well as manually.
+
+This section describes the accuracy/precision handling in Math::Big* as it
+used to be and as it is now, complete with an explanation of all terms and
+abbreviations.
+
+Not yet implemented things (but with correct description) are marked with '!',
+things that need to be answered are marked with '?'.
+
+In the next paragraph follows a short description of terms used here (because
+these may differ from terms used by others people or documentation).
+
+During the rest of this document, the shortcuts A (for accuracy), P (for
+precision), F (fallback) and R (rounding mode) will be used.
+
+=head2 Precision P
+
+A fixed number of digits before (positive) or after (negative)
+the decimal point. For example, 123.45 has a precision of -2. 0 means an
+integer like 123 (or 120). A precision of 2 means two digits to the left
+of the decimal point are zero, so 123 with P = 1 becomes 120. Note that
+numbers with zeros before the decimal point may have different precisions,
+because 1200 can have p = 0, 1 or 2 (depending on what the inital value
+was). It could also have p < 0, when the digits after the decimal point
+are zero.
+
+The string output (of floating point numbers) will be padded with zeros:
+
+ Initial value P A Result String
+ ------------------------------------------------------------
+ 1234.01 -3 1000 1000
+ 1234 -2 1200 1200
+ 1234.5 -1 1230 1230
+ 1234.001 1 1234 1234.0
+ 1234.01 0 1234 1234
+ 1234.01 2 1234.01 1234.01
+ 1234.01 5 1234.01 1234.01000
+
+For BigInts, no padding occurs.
+
+=head2 Accuracy A
+
+Number of significant digits. Leading zeros are not counted. A
+number may have an accuracy greater than the non-zero digits
+when there are zeros in it or trailing zeros. For example, 123.456 has
+A of 6, 10203 has 5, 123.0506 has 7, 123.450000 has 8 and 0.000123 has 3.
+
+The string output (of floating point numbers) will be padded with zeros:
+
+ Initial value P A Result String
+ ------------------------------------------------------------
+ 1234.01 3 1230 1230
+ 1234.01 6 1234.01 1234.01
+ 1234.1 8 1234.1 1234.1000
+
+For BigInts, no padding occurs.
+
+=head2 Fallback F
+
+When both A and P are undefined, this is used as a fallback accuracy when
+dividing numbers.
+
+=head2 Rounding mode R
+
+When rounding a number, different 'styles' or 'kinds'
+of rounding are possible. (Note that random rounding, as in
+Math::Round, is not implemented.)
+
+=over 2
+
+=item 'trunc'
+
+truncation invariably removes all digits following the
+rounding place, replacing them with zeros. Thus, 987.65 rounded
+to tens (P=1) becomes 980, and rounded to the fourth sigdig
+becomes 987.6 (A=4). 123.456 rounded to the second place after the
+decimal point (P=-2) becomes 123.46.
+
+All other implemented styles of rounding attempt to round to the
+"nearest digit." If the digit D immediately to the right of the
+rounding place (skipping the decimal point) is greater than 5, the
+number is incremented at the rounding place (possibly causing a
+cascade of incrementation): e.g. when rounding to units, 0.9 rounds
+to 1, and -19.9 rounds to -20. If D < 5, the number is similarly
+truncated at the rounding place: e.g. when rounding to units, 0.4
+rounds to 0, and -19.4 rounds to -19.
+
+However the results of other styles of rounding differ if the
+digit immediately to the right of the rounding place (skipping the
+decimal point) is 5 and if there are no digits, or no digits other
+than 0, after that 5. In such cases:
+
+=item 'even'
+
+rounds the digit at the rounding place to 0, 2, 4, 6, or 8
+if it is not already. E.g., when rounding to the first sigdig, 0.45
+becomes 0.4, -0.55 becomes -0.6, but 0.4501 becomes 0.5.
+
+=item 'odd'
+
+rounds the digit at the rounding place to 1, 3, 5, 7, or 9 if
+it is not already. E.g., when rounding to the first sigdig, 0.45
+becomes 0.5, -0.55 becomes -0.5, but 0.5501 becomes 0.6.
+
+=item '+inf'
+
+round to plus infinity, i.e. always round up. E.g., when
+rounding to the first sigdig, 0.45 becomes 0.5, -0.55 becomes -0.5,
+and 0.4501 also becomes 0.5.
+
+=item '-inf'
+
+round to minus infinity, i.e. always round down. E.g., when
+rounding to the first sigdig, 0.45 becomes 0.4, -0.55 becomes -0.6,
+but 0.4501 becomes 0.5.
+
+=item 'zero'
+
+round to zero, i.e. positive numbers down, negative ones up.
+E.g., when rounding to the first sigdig, 0.45 becomes 0.4, -0.55
+becomes -0.5, but 0.4501 becomes 0.5.
+
+=item 'common'
+
+round up if the digit immediately to the right of the rounding place
+is 5 or greater, otherwise round down. E.g., 0.15 becomes 0.2 and
+0.149 becomes 0.1.
+
+=back
+
+The handling of A & P in MBI/MBF (the old core code shipped with Perl
+versions <= 5.7.2) is like this:
+
+=over 2
+
+=item Precision
+
+ * ffround($p) is able to round to $p number of digits after the decimal
+ point
+ * otherwise P is unused
+
+=item Accuracy (significant digits)
+
+ * fround($a) rounds to $a significant digits
+ * only fdiv() and fsqrt() take A as (optional) paramater
+ + other operations simply create the same number (fneg etc), or more (fmul)
+ of digits
+ + rounding/truncating is only done when explicitly calling one of fround
+ or ffround, and never for BigInt (not implemented)
+ * fsqrt() simply hands its accuracy argument over to fdiv.
+ * the documentation and the comment in the code indicate two different ways
+ on how fdiv() determines the maximum number of digits it should calculate,
+ and the actual code does yet another thing
+ POD:
+ max($Math::BigFloat::div_scale,length(dividend)+length(divisor))
+ Comment:
+ result has at most max(scale, length(dividend), length(divisor)) digits
+ Actual code:
+ scale = max(scale, length(dividend)-1,length(divisor)-1);
+ scale += length(divisor) - length(dividend);
+ So for lx = 3, ly = 9, scale = 10, scale will actually be 16 (10+9-3).
+ Actually, the 'difference' added to the scale is calculated from the
+ number of "significant digits" in dividend and divisor, which is derived
+ by looking at the length of the mantissa. Which is wrong, since it includes
+ the + sign (oops) and actually gets 2 for '+100' and 4 for '+101'. Oops
+ again. Thus 124/3 with div_scale=1 will get you '41.3' based on the strange
+ assumption that 124 has 3 significant digits, while 120/7 will get you
+ '17', not '17.1' since 120 is thought to have 2 significant digits.
+ The rounding after the division then uses the remainder and $y to determine
+ wether it must round up or down.
+ ? I have no idea which is the right way. That's why I used a slightly more
+ ? simple scheme and tweaked the few failing testcases to match it.
+
+=back
+
+This is how it works now:
+
+=over 2
+
+=item Setting/Accessing
+
+ * You can set the A global via C<< Math::BigInt->accuracy() >> or
+ C<< Math::BigFloat->accuracy() >> or whatever class you are using.
+ * You can also set P globally by using C<< Math::SomeClass->precision() >>
+ likewise.
+ * Globals are classwide, and not inherited by subclasses.
+ * to undefine A, use C<< Math::SomeCLass->accuracy(undef); >>
+ * to undefine P, use C<< Math::SomeClass->precision(undef); >>
+ * Setting C<< Math::SomeClass->accuracy() >> clears automatically
+ C<< Math::SomeClass->precision() >>, and vice versa.
+ * To be valid, A must be > 0, P can have any value.
+ * If P is negative, this means round to the P'th place to the right of the
+ decimal point; positive values mean to the left of the decimal point.
+ P of 0 means round to integer.
+ * to find out the current global A, use C<< Math::SomeClass->accuracy() >>
+ * to find out the current global P, use C<< Math::SomeClass->precision() >>
+ * use C<< $x->accuracy() >> respective C<< $x->precision() >> for the local
+ setting of C<< $x >>.
+ * Please note that C<< $x->accuracy() >> respective C<< $x->precision() >>
+ return eventually defined global A or P, when C<< $x >>'s A or P is not
+ set.
+
+=item Creating numbers
+
+ * When you create a number, you can give the desired A or P via:
+ $x = Math::BigInt->new($number,$A,$P);
+ * Only one of A or P can be defined, otherwise the result is NaN
+ * If no A or P is give ($x = Math::BigInt->new($number) form), then the
+ globals (if set) will be used. Thus changing the global defaults later on
+ will not change the A or P of previously created numbers (i.e., A and P of
+ $x will be what was in effect when $x was created)
+ * If given undef for A and P, B<no> rounding will occur, and the globals will
+ B<not> be used. This is used by subclasses to create numbers without
+ suffering rounding in the parent. Thus a subclass is able to have its own
+ globals enforced upon creation of a number by using
+ C<< $x = Math::BigInt->new($number,undef,undef) >>:
+
+ use Math::BigInt::SomeSubclass;
+ use Math::BigInt;
+
+ Math::BigInt->accuracy(2);
+ Math::BigInt::SomeSubClass->accuracy(3);
+ $x = Math::BigInt::SomeSubClass->new(1234);
+
+ $x is now 1230, and not 1200. A subclass might choose to implement
+ this otherwise, e.g. falling back to the parent's A and P.
+
+=item Usage
+
+ * If A or P are enabled/defined, they are used to round the result of each
+ operation according to the rules below
+ * Negative P is ignored in Math::BigInt, since BigInts never have digits
+ after the decimal point
+ * Math::BigFloat uses Math::BigInt internally, but setting A or P inside
+ Math::BigInt as globals does not tamper with the parts of a BigFloat.
+ A flag is used to mark all Math::BigFloat numbers as 'never round'.
+
+=item Precedence
+
+ * It only makes sense that a number has only one of A or P at a time.
+ If you set either A or P on one object, or globally, the other one will
+ be automatically cleared.
+ * If two objects are involved in an operation, and one of them has A in
+ effect, and the other P, this results in an error (NaN).
+ * A takes precedence over P (Hint: A comes before P).
+ If neither of them is defined, nothing is used, i.e. the result will have
+ as many digits as it can (with an exception for fdiv/fsqrt) and will not
+ be rounded.
+ * There is another setting for fdiv() (and thus for fsqrt()). If neither of
+ A or P is defined, fdiv() will use a fallback (F) of $div_scale digits.
+ If either the dividend's or the divisor's mantissa has more digits than
+ the value of F, the higher value will be used instead of F.
+ This is to limit the digits (A) of the result (just consider what would
+ happen with unlimited A and P in the case of 1/3 :-)
+ * fdiv will calculate (at least) 4 more digits than required (determined by
+ A, P or F), and, if F is not used, round the result
+ (this will still fail in the case of a result like 0.12345000000001 with A
+ or P of 5, but this can not be helped - or can it?)
+ * Thus you can have the math done by on Math::Big* class in two modi:
+ + never round (this is the default):
+ This is done by setting A and P to undef. No math operation
+ will round the result, with fdiv() and fsqrt() as exceptions to guard
+ against overflows. You must explicitly call bround(), bfround() or
+ round() (the latter with parameters).
+ Note: Once you have rounded a number, the settings will 'stick' on it
+ and 'infect' all other numbers engaged in math operations with it, since
+ local settings have the highest precedence. So, to get SaferRound[tm],
+ use a copy() before rounding like this:
+
+ $x = Math::BigFloat->new(12.34);
+ $y = Math::BigFloat->new(98.76);
+ $z = $x * $y; # 1218.6984
+ print $x->copy()->fround(3); # 12.3 (but A is now 3!)
+ $z = $x * $y; # still 1218.6984, without
+ # copy would have been 1210!
+
+ + round after each op:
+ After each single operation (except for testing like is_zero()), the
+ method round() is called and the result is rounded appropriately. By
+ setting proper values for A and P, you can have all-the-same-A or
+ all-the-same-P modes. For example, Math::Currency might set A to undef,
+ and P to -2, globally.
+
+ ?Maybe an extra option that forbids local A & P settings would be in order,
+ ?so that intermediate rounding does not 'poison' further math?
+
+=item Overriding globals
+
+ * you will be able to give A, P and R as an argument to all the calculation
+ routines; the second parameter is A, the third one is P, and the fourth is
+ R (shift right by one for binary operations like badd). P is used only if
+ the first parameter (A) is undefined. These three parameters override the
+ globals in the order detailed as follows, i.e. the first defined value
+ wins:
+ (local: per object, global: global default, parameter: argument to sub)
+ + parameter A
+ + parameter P
+ + local A (if defined on both of the operands: smaller one is taken)
+ + local P (if defined on both of the operands: bigger one is taken)
+ + global A
+ + global P
+ + global F
+ * fsqrt() will hand its arguments to fdiv(), as it used to, only now for two
+ arguments (A and P) instead of one
+
+=item Local settings
+
+ * You can set A or P locally by using C<< $x->accuracy() >> or
+ C<< $x->precision() >>
+ and thus force different A and P for different objects/numbers.
+ * Setting A or P this way immediately rounds $x to the new value.
+ * C<< $x->accuracy() >> clears C<< $x->precision() >>, and vice versa.
+
+=item Rounding
+
+ * the rounding routines will use the respective global or local settings.
+ fround()/bround() is for accuracy rounding, while ffround()/bfround()
+ is for precision
+ * the two rounding functions take as the second parameter one of the
+ following rounding modes (R):
+ 'even', 'odd', '+inf', '-inf', 'zero', 'trunc', 'common'
+ * you can set/get the global R by using C<< Math::SomeClass->round_mode() >>
+ or by setting C<< $Math::SomeClass::round_mode >>
+ * after each operation, C<< $result->round() >> is called, and the result may
+ eventually be rounded (that is, if A or P were set either locally,
+ globally or as parameter to the operation)
+ * to manually round a number, call C<< $x->round($A,$P,$round_mode); >>
+ this will round the number by using the appropriate rounding function
+ and then normalize it.
+ * rounding modifies the local settings of the number:
+
+ $x = Math::BigFloat->new(123.456);
+ $x->accuracy(5);
+ $x->bround(4);
+
+ Here 4 takes precedence over 5, so 123.5 is the result and $x->accuracy()
+ will be 4 from now on.
+
+=item Default values
+
+ * R: 'even'
+ * F: 40
+ * A: undef
+ * P: undef
+
+=item Remarks
+
+ * The defaults are set up so that the new code gives the same results as
+ the old code (except in a few cases on fdiv):
+ + Both A and P are undefined and thus will not be used for rounding
+ after each operation.
+ + round() is thus a no-op, unless given extra parameters A and P
+
+=back
+
+=head1 Infinity and Not a Number
+
+While BigInt has extensive handling of inf and NaN, certain quirks remain.
+
+=over 2
+
+=item oct()/hex()
+
+These perl routines currently (as of Perl v.5.8.6) cannot handle passed
+inf.
+
+ te@linux:~> perl -wle 'print 2 ** 3333'
+ inf
+ te@linux:~> perl -wle 'print 2 ** 3333 == 2 ** 3333'
+ 1
+ te@linux:~> perl -wle 'print oct(2 ** 3333)'
+ 0
+ te@linux:~> perl -wle 'print hex(2 ** 3333)'
+ Illegal hexadecimal digit 'i' ignored at -e line 1.
+ 0
+
+The same problems occur if you pass them Math::BigInt->binf() objects. Since
+overloading these routines is not possible, this cannot be fixed from BigInt.
+
+=item ==, !=, <, >, <=, >= with NaNs
+
+BigInt's bcmp() routine currently returns undef to signal that a NaN was
+involved in a comparison. However, the overload code turns that into
+either 1 or '' and thus operations like C<< NaN != NaN >> might return
+wrong values.
+
+=item log(-inf)
+
+C<< log(-inf) >> is highly weird. Since log(-x)=pi*i+log(x), then
+log(-inf)=pi*i+inf. However, since the imaginary part is finite, the real
+infinity "overshadows" it, so the number might as well just be infinity.
+However, the result is a complex number, and since BigInt/BigFloat can only
+have real numbers as results, the result is NaN.
+
+=item exp(), cos(), sin(), atan2()
+
+These all might have problems handling infinity right.
+
+=back
+
+=head1 INTERNALS
+
+The actual numbers are stored as unsigned big integers (with seperate sign).
+
+You should neither care about nor depend on the internal representation; it
+might change without notice. Use B<ONLY> method calls like C<< $x->sign(); >>
+instead relying on the internal representation.
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+C<Math::BigInt::Calc>. This is equivalent to saying:
+
+ use Math::BigInt try => 'Calc';
+
+You can change this backend library by using:
+
+ use Math::BigInt try => 'GMP';
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+If your script works with huge numbers and Calc is too slow for them,
+you can also for the loading of one of these libraries and if none
+of them can be used, the code will die:
+
+ use Math::BigInt only => 'GMP,Pari';
+
+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 Math::BigInt try => 'Foo,Math::BigInt::Bar';
+
+The library that is loaded last will be used. Note that this can be
+overwritten at any time by loading a different library, and numbers
+constructed with different libraries cannot be used in math operations
+together.
+
+=head3 What library to use?
+
+B<Note>: General purpose packages should not be explicit about the library
+to use; let the script author decide which is best.
+
+L<Math::BigInt::GMP> and L<Math::BigInt::Pari> are in cases involving big
+numbers much faster than Calc, however it is slower when dealing with very
+small numbers (less than about 20 digits) and when converting very large
+numbers to decimal (for instance for printing, rounding, calculating their
+length in decimal etc).
+
+So please select carefully what libary you want to use.
+
+Different low-level libraries use different formats to store the numbers.
+However, you should B<NOT> depend on the number having a specific format
+internally.
+
+See the respective math library 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 mantissa(), exponent() and parts()
+
+C<mantissa()> and C<exponent()> return the said parts of the BigInt such
+that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+C<< ($m,$e) = $x->parts() >> is just a shortcut that gives you both of them
+in one go. Both the returned mantissa and exponent have a sign.
+
+Currently, for BigInts C<$e> is always 0, except +inf and -inf, where it is
+C<+inf>; and for NaN, where it is C<NaN>; and for C<$x == 0>, where it is C<1>
+(to be compatible with Math::BigFloat's internal representation of a zero as
+C<0E1>).
+
+C<$m> is currently just a copy of the original number. The relation between
+C<$e> and C<$m> will stay always the same, though their real values might
+change.
+
+=head1 EXAMPLES
+
+ use Math::BigInt;
+
+ sub bint { Math::BigInt->new(shift); }
+
+ $x = Math::BigInt->bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = Math::BigInt->bneg("1234"); # BigInt "-1234"
+ $x = Math::BigInt->babs("-12345"); # BigInt "12345"
+ $x = Math::BigInt->bnorm("-0.00"); # BigInt "0"
+ $x = bint(1) + bint(2); # BigInt "3"
+ $x = bint(1) + "2"; # ditto (auto-BigIntify of "2")
+ $x = bint(1); # BigInt "1"
+ $x = $x + 5 / 2; # BigInt "3"
+ $x = $x ** 3; # BigInt "27"
+ $x *= 2; # BigInt "54"
+ $x = Math::BigInt->new(0); # BigInt "0"
+ $x--; # BigInt "-1"
+ $x = Math::BigInt->badd(4,5) # BigInt "9"
+ print $x->bsstr(); # 9e+0
+
+Examples for rounding:
+
+ use Math::BigFloat;
+ use Test;
+
+ $x = Math::BigFloat->new(123.4567);
+ $y = Math::BigFloat->new(123.456789);
+ Math::BigFloat->accuracy(4); # no more A than 4
+
+ ok ($x->copy()->fround(),123.4); # even rounding
+ print $x->copy()->fround(),"\n"; # 123.4
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.5
+ Math::BigFloat->accuracy(5); # no more A than 5
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.46
+ $y = $x->copy()->fround(4),"\n"; # A = 4: 123.4
+ print "$y, ",$y->accuracy(),"\n"; # 123.4, 4
+
+ Math::BigFloat->accuracy(undef); # A not important now
+ Math::BigFloat->precision(2); # P important
+ print $x->copy()->bnorm(),"\n"; # 123.46
+ print $x->copy()->fround(),"\n"; # 123.46
+
+Examples for converting:
+
+ my $x = Math::BigInt->new('0b1'.'01' x 123);
+ print "bin: ",$x->as_bin()," hex:",$x->as_hex()," dec: ",$x,"\n";
+
+=head1 Autocreating constants
+
+After C<use Math::BigInt ':constant'> all the B<integer> decimal, hexadecimal
+and binary constants in the given scope are converted to C<Math::BigInt>.
+This conversion happens at compile time.
+
+In particular,
+
+ perl -MMath::BigInt=:constant -e 'print 2**100,"\n"'
+
+prints the integer value of C<2**100>. Note that without conversion of
+constants the expression 2**100 will be calculated as perl scalar.
+
+Please note that strings and floating point constants are not affected,
+so that
+
+ use Math::BigInt qw/:constant/;
+
+ $x = 1234567890123456789012345678901234567890
+ + 123456789123456789;
+ $y = '1234567890123456789012345678901234567890'
+ + '123456789123456789';
+
+do not work. You need an explicit Math::BigInt->new() around one of the
+operands. You should also quote large constants to protect loss of precision:
+
+ use Math::BigInt;
+
+ $x = Math::BigInt->new('1234567889123456789123456789123456789');
+
+Without the quotes Perl would convert the large number to a floating point
+constant at compile time and then hand the result to BigInt, which results in
+an truncated result or a NaN.
+
+This also applies to integers that look like floating point constants:
+
+ use Math::BigInt ':constant';
+
+ print ref(123e2),"\n";
+ print ref(123.2e2),"\n";
+
+will print nothing but newlines. Use either L<bignum> or L<Math::BigFloat>
+to get this to work.
+
+=head1 PERFORMANCE
+
+Using the form $x += $y; etc over $x = $x + $y is faster, since a copy of $x
+must be made in the second case. For long numbers, the copy can eat up to 20%
+of the work (in the case of addition/subtraction, less for
+multiplication/division). If $y is very small compared to $x, the form
+$x += $y is MUCH faster than $x = $x + $y since making the copy of $x takes
+more time then the actual addition.
+
+With a technique called copy-on-write, the cost of copying with overload could
+be minimized or even completely avoided. A test implementation of COW did show
+performance gains for overloaded math, but introduced a performance loss due
+to a constant overhead for all other operations. So Math::BigInt does currently
+not COW.
+
+The rewritten version of this module (vs. v0.01) is slower on certain
+operations, like C<new()>, C<bstr()> and C<numify()>. The reason are that it
+does now more work and handles much more cases. The time spent in these
+operations is usually gained in the other math operations so that code on
+the average should get (much) faster. If they don't, please contact the author.
+
+Some operations may be slower for small numbers, but are significantly faster
+for big numbers. Other operations are now constant (O(1), like C<bneg()>,
+C<babs()> etc), instead of O(N) and thus nearly always take much less time.
+These optimizations were done on purpose.
+
+If you find the Calc module to slow, try to install any of the replacement
+modules and see if they help you.
+
+=head2 Alternative math libraries
+
+You can use an alternative library to drive Math::BigInt. See the section
+L<MATH LIBRARY> for more information.
+
+For more benchmark results see L<http://bloodgate.com/perl/benchmarks.html>.
+
+=head2 SUBCLASSING
+
+=head1 Subclassing Math::BigInt
+
+The basic design of Math::BigInt allows simple subclasses with very little
+work, as long as a few simple rules are followed:
+
+=over 2
+
+=item *
+
+The public API must remain consistent, i.e. if a sub-class is overloading
+addition, the sub-class must use the same name, in this case badd(). The
+reason for this is that Math::BigInt is optimized to call the object methods
+directly.
+
+=item *
+
+The private object hash keys like C<$x->{sign}> may not be changed, but
+additional keys can be added, like C<$x->{_custom}>.
+
+=item *
+
+Accessor functions are available for all existing object hash keys and should
+be used instead of directly accessing the internal hash keys. The reason for
+this is that Math::BigInt itself has a pluggable interface which permits it
+to support different storage methods.
+
+=back
+
+More complex sub-classes may have to replicate more of the logic internal of
+Math::BigInt if they need to change more basic behaviors. A subclass that
+needs to merely change the output only needs to overload C<bstr()>.
+
+All other object methods and overloaded functions can be directly inherited
+from the parent class.
+
+At the very minimum, any subclass will need to provide its own C<new()> and can
+store additional hash keys in the object. There are also some package globals
+that must be defined, e.g.:
+
+ # Globals
+ $accuracy = undef;
+ $precision = -2; # round to 2 decimal places
+ $round_mode = 'even';
+ $div_scale = 40;
+
+Additionally, you might want to provide the following two globals to allow
+auto-upgrading and auto-downgrading to work correctly:
+
+ $upgrade = undef;
+ $downgrade = undef;
+
+This allows Math::BigInt to correctly retrieve package globals from the
+subclass, like C<$SubClass::precision>. See t/Math/BigInt/Subclass.pm or
+t/Math/BigFloat/SubClass.pm completely functional subclass examples.
+
+Don't forget to
+
+ use overload;
+
+in your subclass to automatically inherit the overloading from the parent. If
+you like, you can change part of the overloading, look at Math::String for an
+example.
+
+=head1 UPGRADING
+
+When used like this:
+
+ use Math::BigInt upgrade => 'Foo::Bar';
+
+certain operations will 'upgrade' their calculation and thus the result to
+the class Foo::Bar. Usually this is used in conjunction with Math::BigFloat:
+
+ use Math::BigInt upgrade => 'Math::BigFloat';
+
+As a shortcut, you can use the module C<bignum>:
+
+ use bignum;
+
+Also good for oneliners:
+
+ perl -Mbignum -le 'print 2 ** 255'
+
+This makes it possible to mix arguments of different classes (as in 2.5 + 2)
+as well es preserve accuracy (as in sqrt(3)).
+
+Beware: This feature is not fully implemented yet.
+
+=head2 Auto-upgrade
+
+The following methods upgrade themselves unconditionally; that is if upgrade
+is in effect, they will always hand up their work:
+
+=over 2
+
+=item bsqrt()
+
+=item div()
+
+=item blog()
+
+=item bexp()
+
+=back
+
+Beware: This list is not complete.
+
+All other methods upgrade themselves only when one (or all) of their
+arguments are of the class mentioned in $upgrade (This might change in later
+versions to a more sophisticated scheme):
+
+=head1 EXPORTS
+
+C<Math::BigInt> exports nothing by default, but can export the following methods:
+
+ bgcd
+ blcm
+
+=head1 CAVEATS
+
+Some things might not work as you expect them. Below is documented what is
+known to be troublesome:
+
+=over 1
+
+=item bstr(), bsstr() and 'cmp'
+
+Both C<bstr()> and C<bsstr()> as well as automated stringify via overload now
+drop the leading '+'. The old code would return '+3', the new returns '3'.
+This is to be consistent with Perl and to make C<cmp> (especially with
+overloading) to work as you expect. It also solves problems with C<Test.pm>,
+because its C<ok()> uses 'eq' internally.
+
+Mark Biggar said, when asked about to drop the '+' altogether, or make only
+C<cmp> work:
+
+ I agree (with the first alternative), don't add the '+' on positive
+ numbers. It's not as important anymore with the new internal
+ form for numbers. It made doing things like abs and neg easier,
+ but those have to be done differently now anyway.
+
+So, the following examples will now work all as expected:
+
+ use Test;
+ BEGIN { plan tests => 1 }
+ use Math::BigInt;
+
+ my $x = new Math::BigInt 3*3;
+ my $y = new Math::BigInt 3*3;
+
+ ok ($x,3*3);
+ print "$x eq 9" if $x eq $y;
+ print "$x eq 9" if $x eq '9';
+ print "$x eq 9" if $x eq 3*3;
+
+Additionally, the following still works:
+
+ print "$x == 9" if $x == $y;
+ print "$x == 9" if $x == 9;
+ print "$x == 9" if $x == 3*3;
+
+There is now a C<bsstr()> method to get the string in scientific notation aka
+C<1e+2> instead of C<100>. Be advised that overloaded 'eq' always uses bstr()
+for comparison, but Perl will represent some numbers as 100 and others
+as 1e+308. If in doubt, convert both arguments to Math::BigInt before
+comparing them as strings:
+
+ use Test;
+ BEGIN { plan tests => 3 }
+ use Math::BigInt;
+
+ $x = Math::BigInt->new('1e56'); $y = 1e56;
+ ok ($x,$y); # will fail
+ ok ($x->bsstr(),$y); # okay
+ $y = Math::BigInt->new($y);
+ ok ($x,$y); # okay
+
+Alternatively, simple use C<< <=> >> for comparisons, this will get it
+always right. There is not yet a way to get a number automatically represented
+as a string that matches exactly the way Perl represents it.
+
+See also the section about L<Infinity and Not a Number> for problems in
+comparing NaNs.
+
+=item int()
+
+C<int()> will return (at least for Perl v5.7.1 and up) another BigInt, not a
+Perl scalar:
+
+ $x = Math::BigInt->new(123);
+ $y = int($x); # BigInt 123
+ $x = Math::BigFloat->new(123.45);
+ $y = int($x); # BigInt 123
+
+In all Perl versions you can use C<as_number()> or C<as_int> for the same
+effect:
+
+ $x = Math::BigFloat->new(123.45);
+ $y = $x->as_number(); # BigInt 123
+ $y = $x->as_int(); # ditto
+
+This also works for other subclasses, like Math::String.
+
+If you want a real Perl scalar, use C<numify()>:
+
+ $y = $x->numify(); # 123 as scalar
+
+This is seldom necessary, though, because this is done automatically, like
+when you access an array:
+
+ $z = $array[$x]; # does work automatically
+
+=item length
+
+The following will probably not do what you expect:
+
+ $c = Math::BigInt->new(123);
+ print $c->length(),"\n"; # prints 30
+
+It prints both the number of digits in the number and in the fraction part
+since print calls C<length()> in list context. Use something like:
+
+ print scalar $c->length(),"\n"; # prints 3
+
+=item bdiv
+
+The following will probably not do what you expect:
+
+ print $c->bdiv(10000),"\n";
+
+It prints both quotient and remainder since print calls C<bdiv()> in list
+context. Also, C<bdiv()> will modify $c, so be careful. You probably want
+to use
+
+ print $c / 10000,"\n";
+ print scalar $c->bdiv(10000),"\n"; # or if you want to modify $c
+
+instead.
+
+The quotient is always the greatest integer less than or equal to the
+real-valued quotient of the two operands, and the remainder (when it is
+nonzero) always has the same sign as the second operand; so, for
+example,
+
+ 1 / 4 => ( 0, 1)
+ 1 / -4 => (-1,-3)
+ -3 / 4 => (-1, 1)
+ -3 / -4 => ( 0,-3)
+ -11 / 2 => (-5,1)
+ 11 /-2 => (-5,-1)
+
+As a consequence, the behavior of the operator % agrees with the
+behavior of Perl's built-in % operator (as documented in the perlop
+manpage), and the equation
+
+ $x == ($x / $y) * $y + ($x % $y)
+
+holds true for any $x and $y, which justifies calling the two return
+values of bdiv() the quotient and remainder. The only exception to this rule
+are when $y == 0 and $x is negative, then the remainder will also be
+negative. See below under "infinity handling" for the reasoning behind this.
+
+Perl's 'use integer;' changes the behaviour of % and / for scalars, but will
+not change BigInt's way to do things. This is because under 'use integer' Perl
+will do what the underlying C thinks is right and this is different for each
+system. If you need BigInt's behaving exactly like Perl's 'use integer', bug
+the author to implement it ;)
+
+=item infinity handling
+
+Here are some examples that explain the reasons why certain results occur while
+handling infinity:
+
+The following table shows the result of the division and the remainder, so that
+the equation above holds true. Some "ordinary" cases are strewn in to show more
+clearly the reasoning:
+
+ A / B = C, R so that C * B + R = A
+ =========================================================
+ 5 / 8 = 0, 5 0 * 8 + 5 = 5
+ 0 / 8 = 0, 0 0 * 8 + 0 = 0
+ 0 / inf = 0, 0 0 * inf + 0 = 0
+ 0 /-inf = 0, 0 0 * -inf + 0 = 0
+ 5 / inf = 0, 5 0 * inf + 5 = 5
+ 5 /-inf = 0, 5 0 * -inf + 5 = 5
+ -5/ inf = 0, -5 0 * inf + -5 = -5
+ -5/-inf = 0, -5 0 * -inf + -5 = -5
+ inf/ 5 = inf, 0 inf * 5 + 0 = inf
+ -inf/ 5 = -inf, 0 -inf * 5 + 0 = -inf
+ inf/ -5 = -inf, 0 -inf * -5 + 0 = inf
+ -inf/ -5 = inf, 0 inf * -5 + 0 = -inf
+ 5/ 5 = 1, 0 1 * 5 + 0 = 5
+ -5/ -5 = 1, 0 1 * -5 + 0 = -5
+ inf/ inf = 1, 0 1 * inf + 0 = inf
+ -inf/-inf = 1, 0 1 * -inf + 0 = -inf
+ inf/-inf = -1, 0 -1 * -inf + 0 = inf
+ -inf/ inf = -1, 0 1 * -inf + 0 = -inf
+ 8/ 0 = inf, 8 inf * 0 + 8 = 8
+ inf/ 0 = inf, inf inf * 0 + inf = inf
+ 0/ 0 = NaN
+
+These cases below violate the "remainder has the sign of the second of the two
+arguments", since they wouldn't match up otherwise.
+
+ A / B = C, R so that C * B + R = A
+ ========================================================
+ -inf/ 0 = -inf, -inf -inf * 0 + inf = -inf
+ -8/ 0 = -inf, -8 -inf * 0 + 8 = -8
+
+=item Modifying and =
+
+Beware of:
+
+ $x = Math::BigFloat->new(5);
+ $y = $x;
+
+It will not do what you think, e.g. making a copy of $x. Instead it just makes
+a second reference to the B<same> object and stores it in $y. Thus anything
+that modifies $x (except overloaded operators) will modify $y, and vice versa.
+Or in other words, C<=> is only safe if you modify your BigInts only via
+overloaded math. As soon as you use a method call it breaks:
+
+ $x->bmul(2);
+ print "$x, $y\n"; # prints '10, 10'
+
+If you want a true copy of $x, use:
+
+ $y = $x->copy();
+
+You can also chain the calls like this, this will make first a copy and then
+multiply it by 2:
+
+ $y = $x->copy()->bmul(2);
+
+See also the documentation for overload.pm regarding C<=>.
+
+=item bpow
+
+C<bpow()> (and the rounding functions) now modifies the first argument and
+returns it, unlike the old code which left it alone and only returned the
+result. This is to be consistent with C<badd()> etc. The first three will
+modify $x, the last one won't:
+
+ print bpow($x,$i),"\n"; # modify $x
+ print $x->bpow($i),"\n"; # ditto
+ print $x **= $i,"\n"; # the same
+ print $x ** $i,"\n"; # leave $x alone
+
+The form C<$x **= $y> is faster than C<$x = $x ** $y;>, though.
+
+=item Overloading -$x
+
+The following:
+
+ $x = -$x;
+
+is slower than
+
+ $x->bneg();
+
+since overload calls C<sub($x,0,1);> instead of C<neg($x)>. The first variant
+needs to preserve $x since it does not know that it later will get overwritten.
+This makes a copy of $x and takes O(N), but $x->bneg() is O(1).
+
+=item Mixing different object types
+
+In Perl you will get a floating point value if you do one of the following:
+
+ $float = 5.0 + 2;
+ $float = 2 + 5.0;
+ $float = 5 / 2;
+
+With overloaded math, only the first two variants will result in a BigFloat:
+
+ use Math::BigInt;
+ use Math::BigFloat;
+
+ $mbf = Math::BigFloat->new(5);
+ $mbi2 = Math::BigInteger->new(5);
+ $mbi = Math::BigInteger->new(2);
+
+ # what actually gets called:
+ $float = $mbf + $mbi; # $mbf->badd()
+ $float = $mbf / $mbi; # $mbf->bdiv()
+ $integer = $mbi + $mbf; # $mbi->badd()
+ $integer = $mbi2 / $mbi; # $mbi2->bdiv()
+ $integer = $mbi2 / $mbf; # $mbi2->bdiv()
+
+This is because math with overloaded operators follows the first (dominating)
+operand, and the operation of that is called and returns thus the result. So,
+Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether
+the result should be a Math::BigFloat or the second operant is one.
+
+To get a Math::BigFloat you either need to call the operation manually,
+make sure the operands are already of the proper type or casted to that type
+via Math::BigFloat->new():
+
+ $float = Math::BigFloat->new($mbi2) / $mbi; # = 2.5
+
+Beware of simple "casting" the entire expression, this would only convert
+the already computed result:
+
+ $float = Math::BigFloat->new($mbi2 / $mbi); # = 2.0 thus wrong!
+
+Beware also of the order of more complicated expressions like:
+
+ $integer = ($mbi2 + $mbi) / $mbf; # int / float => int
+ $integer = $mbi2 / Math::BigFloat->new($mbi); # ditto
+
+If in doubt, break the expression into simpler terms, or cast all operands
+to the desired resulting type.
+
+Scalar values are a bit different, since:
+
+ $float = 2 + $mbf;
+ $float = $mbf + 2;
+
+will both result in the proper type due to the way the overloaded math works.
+
+This section also applies to other overloaded math packages, like Math::String.
+
+One solution to you problem might be autoupgrading|upgrading. See the
+pragmas L<bignum>, L<bigint> and L<bigrat> for an easy way to do this.
+
+=item bsqrt()
+
+C<bsqrt()> works only good if the result is a big integer, e.g. the square
+root of 144 is 12, but from 12 the square root is 3, regardless of rounding
+mode. The reason is that the result is always truncated to an integer.
+
+If you want a better approximation of the square root, then use:
+
+ $x = Math::BigFloat->new(12);
+ Math::BigFloat->precision(0);
+ Math::BigFloat->round_mode('even');
+ print $x->copy->bsqrt(),"\n"; # 4
+
+ Math::BigFloat->precision(2);
+ print $x->bsqrt(),"\n"; # 3.46
+ print $x->bsqrt(3),"\n"; # 3.464
+
+=item brsft()
+
+For negative numbers in base see also L<brsft|brsft>.
+
+=back
+
+=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
+
+L<Math::BigFloat>, L<Math::BigRat> and L<Math::Big> as well as
+L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+The pragmas L<bignum>, L<bigint> and L<bigrat> also might be of interest
+because they solve the autoupgrading/downgrading issue, at least partly.
+
+The package at
+L<http://search.cpan.org/search?mode=module&query=Math%3A%3ABigInt> contains
+more documentation including a full version history, testcases, empty
+subclass files and benchmarks.
+
+=head1 AUTHORS
+
+Original code by Mark Biggar, overloaded interface by Ilya Zakharevich.
+Completely rewritten by Tels http://bloodgate.com in late 2000, 2001 - 2006
+and still at it in 2007.
+
+Many people contributed in one or more ways to the final beast, see the file
+CREDITS for an (incomplete) list. If you miss your name, please drop me a
+mail. Thank you!
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm b/Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm
new file mode 100644
index 00000000000..52e33d232ae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm
@@ -0,0 +1,2612 @@
+package Math::BigInt::Calc;
+
+use 5.006;
+use strict;
+# use warnings; # dont use warnings for older Perls
+
+our $VERSION = '0.52';
+
+# Package to store unsigned big integers in decimal and do math with them
+
+# Internally the numbers are stored in an array with at least 1 element, no
+# leading zero parts (except the first) and in base 1eX where X is determined
+# automatically at loading time to be the maximum possible value
+
+# todo:
+# - fully remove funky $# stuff in div() (maybe - that code scares me...)
+
+# USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used
+# instead of "/ 1e5" at some places, (marked with USE_MUL). Other platforms
+# BS2000, some Crays need USE_DIV instead.
+# The BEGIN block is used to determine which of the two variants gives the
+# correct result.
+
+# Beware of things like:
+# $i = $i * $y + $car; $car = int($i / $BASE); $i = $i % $BASE;
+# This works on x86, but fails on ARM (SA1100, iPAQ) due to whoknows what
+# reasons. So, use this instead (slower, but correct):
+# $i = $i * $y + $car; $car = int($i / $BASE); $i -= $BASE * $car;
+
+##############################################################################
+# global constants, flags and accessory
+
+# announce that we are compatible with MBI v1.83 and up
+sub api_version () { 2; }
+
+# constants for easier life
+my ($BASE,$BASE_LEN,$RBASE,$MAX_VAL);
+my ($AND_BITS,$XOR_BITS,$OR_BITS);
+my ($AND_MASK,$XOR_MASK,$OR_MASK);
+
+sub _base_len
+ {
+ # Set/get the BASE_LEN and assorted other, connected values.
+ # Used only by the testsuite, the set variant is used only by the BEGIN
+ # block below:
+ shift;
+
+ my ($b, $int) = @_;
+ if (defined $b)
+ {
+ # avoid redefinitions
+ undef &_mul;
+ undef &_div;
+
+ if ($] >= 5.008 && $int && $b > 7)
+ {
+ $BASE_LEN = $b;
+ *_mul = \&_mul_use_div_64;
+ *_div = \&_div_use_div_64;
+ $BASE = int("1e".$BASE_LEN);
+ $MAX_VAL = $BASE-1;
+ return $BASE_LEN unless wantarray;
+ return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, $BASE);
+ }
+
+ # find whether we can use mul or div in mul()/div()
+ $BASE_LEN = $b+1;
+ my $caught = 0;
+ while (--$BASE_LEN > 5)
+ {
+ $BASE = int("1e".$BASE_LEN);
+ $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL
+ $caught = 0;
+ $caught += 1 if (int($BASE * $RBASE) != 1); # should be 1
+ $caught += 2 if (int($BASE / $BASE) != 1); # should be 1
+ last if $caught != 3;
+ }
+ $BASE = int("1e".$BASE_LEN);
+ $RBASE = abs('1e-'.$BASE_LEN); # see USE_MUL
+ $MAX_VAL = $BASE-1;
+
+ # ($caught & 1) != 0 => cannot use MUL
+ # ($caught & 2) != 0 => cannot use DIV
+ if ($caught == 2) # 2
+ {
+ # must USE_MUL since we cannot use DIV
+ *_mul = \&_mul_use_mul;
+ *_div = \&_div_use_mul;
+ }
+ else # 0 or 1
+ {
+ # can USE_DIV instead
+ *_mul = \&_mul_use_div;
+ *_div = \&_div_use_div;
+ }
+ }
+ return $BASE_LEN unless wantarray;
+ return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN, $MAX_VAL, $BASE);
+ }
+
+sub _new
+ {
+ # (ref to string) return ref to num_array
+ # Convert a number from string format (without sign) to internal base
+ # 1ex format. Assumes normalized value as input.
+ my $il = length($_[1])-1;
+
+ # < BASE_LEN due len-1 above
+ return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers
+
+ # this leaves '00000' instead of int 0 and will be corrected after any op
+ [ reverse(unpack("a" . ($il % $BASE_LEN+1)
+ . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
+ }
+
+BEGIN
+ {
+ # from Daniel Pfeiffer: determine largest group of digits that is precisely
+ # multipliable with itself plus carry
+ # Test now changed to expect the proper pattern, not a result off by 1 or 2
+ my ($e, $num) = 3; # lowest value we will use is 3+1-1 = 3
+ do
+ {
+ $num = ('9' x ++$e) + 0;
+ $num *= $num + 1.0;
+ } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern
+ $e--; # last test failed, so retract one step
+ # the limits below brush the problems with the test above under the rug:
+ # the test should be able to find the proper $e automatically
+ $e = 5 if $^O =~ /^uts/; # UTS get's some special treatment
+ $e = 5 if $^O =~ /^unicos/; # unicos is also problematic (6 seems to work
+ # there, but we play safe)
+
+ my $int = 0;
+ if ($e > 7)
+ {
+ use integer;
+ my $e1 = 7;
+ $num = 7;
+ do
+ {
+ $num = ('9' x ++$e1) + 0;
+ $num *= $num + 1;
+ } while ("$num" =~ /9{$e1}0{$e1}/); # must be a certain pattern
+ $e1--; # last test failed, so retract one step
+ if ($e1 > 7)
+ {
+ $int = 1; $e = $e1;
+ }
+ }
+
+ __PACKAGE__->_base_len($e,$int); # set and store
+
+ use integer;
+ # find out how many bits _and, _or and _xor can take (old default = 16)
+ # I don't think anybody has yet 128 bit scalars, so let's play safe.
+ local $^W = 0; # don't warn about 'nonportable number'
+ $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15;
+
+ # find max bits, we will not go higher than numberofbits that fit into $BASE
+ # to make _and etc simpler (and faster for smaller, slower for large numbers)
+ my $max = 16;
+ while (2 ** $max < $BASE) { $max++; }
+ {
+ no integer;
+ $max = 16 if $] < 5.006; # older Perls might not take >16 too well
+ }
+ my ($x,$y,$z);
+ do {
+ $AND_BITS++;
+ $x = CORE::oct('0b' . '1' x $AND_BITS); $y = $x & $x;
+ $z = (2 ** $AND_BITS) - 1;
+ } while ($AND_BITS < $max && $x == $z && $y == $x);
+ $AND_BITS --; # retreat one step
+ do {
+ $XOR_BITS++;
+ $x = CORE::oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0;
+ $z = (2 ** $XOR_BITS) - 1;
+ } while ($XOR_BITS < $max && $x == $z && $y == $x);
+ $XOR_BITS --; # retreat one step
+ do {
+ $OR_BITS++;
+ $x = CORE::oct('0b' . '1' x $OR_BITS); $y = $x | $x;
+ $z = (2 ** $OR_BITS) - 1;
+ } while ($OR_BITS < $max && $x == $z && $y == $x);
+ $OR_BITS --; # retreat one step
+
+ $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
+ $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
+ $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
+
+ # We can compute the approximate lenght no faster than the real length:
+ *_alen = \&_len;
+ }
+
+###############################################################################
+
+sub _zero
+ {
+ # create a zero
+ [ 0 ];
+ }
+
+sub _one
+ {
+ # create a one
+ [ 1 ];
+ }
+
+sub _two
+ {
+ # create a two (used internally for shifting)
+ [ 2 ];
+ }
+
+sub _ten
+ {
+ # create a 10 (used internally for shifting)
+ [ 10 ];
+ }
+
+sub _1ex
+ {
+ # create a 1Ex
+ my $rem = $_[1] % $BASE_LEN; # remainder
+ my $parts = $_[1] / $BASE_LEN; # parts
+
+ # 000000, 000000, 100
+ [ (0) x $parts, '1' . ('0' x $rem) ];
+ }
+
+sub _copy
+ {
+ # make a true copy
+ [ @{$_[1]} ];
+ }
+
+# catch and throw away
+sub import { }
+
+##############################################################################
+# convert back to string and number
+
+sub _str
+ {
+ # (ref to BINT) return num_str
+ # Convert number from internal base 100000 format to string format.
+ # internal format is always normalized (no leading zeros, "-0" => "+0")
+ my $ar = $_[1];
+
+ my $l = scalar @$ar; # number of parts
+ if ($l < 1) # should not happen
+ {
+ require Carp;
+ Carp::croak("$_[1] has no elements");
+ }
+
+ my $ret = "";
+ # handle first one different to strip leading zeros from it (there are no
+ # leading zero parts in internal representation)
+ $l --; $ret .= int($ar->[$l]); $l--;
+ # Interestingly, the pre-padd method uses more time
+ # the old grep variant takes longer (14 vs. 10 sec)
+ my $z = '0' x ($BASE_LEN-1);
+ while ($l >= 0)
+ {
+ $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of
+ $l--;
+ }
+ $ret;
+ }
+
+sub _num
+ {
+ # Make a number (scalar int/float) from a BigInt object
+ my $x = $_[1];
+
+ return 0+$x->[0] if scalar @$x == 1; # below $BASE
+ my $fac = 1;
+ my $num = 0;
+ foreach (@$x)
+ {
+ $num += $fac*$_; $fac *= $BASE;
+ }
+ $num;
+ }
+
+##############################################################################
+# actual math code
+
+sub _add
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # routine to add two base 1eX numbers
+ # stolen from Knuth Vol 2 Algorithm A pg 231
+ # there are separate routines to add and sub as per Knuth pg 233
+ # This routine clobbers up array x, but not y.
+
+ my ($c,$x,$y) = @_;
+
+ return $x if (@$y == 1) && $y->[0] == 0; # $x + 0 => $x
+ if ((@$x == 1) && $x->[0] == 0) # 0 + $y => $y->copy
+ {
+ # twice as slow as $x = [ @$y ], but nec. to retain $x as ref :(
+ @$x = @$y; return $x;
+ }
+
+ # for each in Y, add Y to X and carry. If after that, something is left in
+ # X, foreach in X add carry to X and then return X, carry
+ # Trades one "$j++" for having to shift arrays
+ my $i; my $car = 0; my $j = 0;
+ for $i (@$y)
+ {
+ $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
+ $j++;
+ }
+ while ($car != 0)
+ {
+ $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
+ }
+ $x;
+ }
+
+sub _inc
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # Add 1 to $x, modify $x in place
+ my ($c,$x) = @_;
+
+ for my $i (@$x)
+ {
+ return $x if (($i += 1) < $BASE); # early out
+ $i = 0; # overflow, next
+ }
+ push @$x,1 if (($x->[-1] || 0) == 0); # last overflowed, so extend
+ $x;
+ }
+
+sub _dec
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # Sub 1 from $x, modify $x in place
+ my ($c,$x) = @_;
+
+ my $MAX = $BASE-1; # since MAX_VAL based on BASE
+ for my $i (@$x)
+ {
+ last if (($i -= 1) >= 0); # early out
+ $i = $MAX; # underflow, next
+ }
+ pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0)
+ $x;
+ }
+
+sub _sub
+ {
+ # (ref to int_num_array, ref to int_num_array, swap)
+ # subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+ # subtract Y from X by modifying x in place
+ my ($c,$sx,$sy,$s) = @_;
+
+ my $car = 0; my $i; my $j = 0;
+ if (!$s)
+ {
+ for $i (@$sx)
+ {
+ last unless defined $sy->[$j] || $car;
+ $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
+ }
+ # might leave leading zeros, so fix that
+ return __strip_zeros($sx);
+ }
+ for $i (@$sx)
+ {
+ # we can't do an early out if $x is < than $y, since we
+ # need to copy the high chunks from $y. Found by Bob Mathews.
+ #last unless defined $sy->[$j] || $car;
+ $sy->[$j] += $BASE
+ if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
+ $j++;
+ }
+ # might leave leading zeros, so fix that
+ __strip_zeros($sy);
+ }
+
+sub _mul_use_mul
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ my ($c,$xv,$yv) = @_;
+
+ if (@$yv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (@$xv == 1)
+ {
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ $i = $i * $y + $car; $car = int($i * $RBASE); $i -= $car * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+
+ # slow variant
+# for $yi (@$yv)
+# {
+# $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+# $prod[$cty++] =
+# $prod - ($car = int($prod * RBASE)) * $BASE; # see USE_MUL
+# }
+# $prod[$cty] += $car if $car; # need really to check for 0?
+# $xi = shift @prod;
+
+ # faster variant
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+## this is actually a tad slower
+## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here
+ $prod[$cty++] =
+ $prod - ($car = int($prod * $RBASE)) * $BASE; # see USE_MUL
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ # can't have leading zeros
+# __strip_zeros($xv);
+ $xv;
+ }
+
+sub _mul_use_div_64
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ # works for 64 bit integer with "use integer"
+ my ($c,$xv,$yv) = @_;
+
+ use integer;
+ if (@$yv == 1)
+ {
+ # shortcut for two small numbers, also handles $x == 0
+ if (@$xv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] =
+ $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ #$i = $i * $y + $car; $car = $i / $BASE; $i -= $car * $BASE;
+ $i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE;
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ $xv;
+ }
+
+sub _mul_use_div
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ my ($c,$xv,$yv) = @_;
+
+ if (@$yv == 1)
+ {
+ # shortcut for two small numbers, also handles $x == 0
+ if (@$xv == 1)
+ {
+ # shortcut for two very short numbers (improved by Nathan Zook)
+ # works also if xv and yv are the same reference, and handles also $x == 0
+ if (($xv->[0] *= $yv->[0]) >= $BASE)
+ {
+ $xv->[0] =
+ $xv->[0] - ($xv->[1] = int($xv->[0] / $BASE)) * $BASE;
+ };
+ return $xv;
+ }
+ # $x * 0 => 0
+ if ($yv->[0] == 0)
+ {
+ @$xv = (0);
+ return $xv;
+ }
+ # multiply a large number a by a single element one, so speed up
+ my $y = $yv->[0]; my $car = 0;
+ foreach my $i (@$xv)
+ {
+ $i = $i * $y + $car; $car = int($i / $BASE); $i -= $car * $BASE;
+ # This (together with use integer;) does not work on 32-bit Perls
+ #$i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE;
+ }
+ push @$xv, $car if $car != 0;
+ return $xv;
+ }
+ # shortcut for result $x == 0 => result = 0
+ return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) );
+
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if $xv == $yv; # same references?
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+ # looping through this if $xi == 0 is silly - so optimize it away!
+ $xi = (shift @prod || 0), next if $xi == 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] = $prod - ($car = int($prod / $BASE)) * $BASE;
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod || 0; # || 0 makes v5.005_3 happy
+ }
+ push @$xv, @prod;
+ # can't have leading zeros
+# __strip_zeros($xv);
+ $xv;
+ }
+
+sub _div_use_mul
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+
+ # see comments in _div_use_div() for more explanations
+
+ my ($c,$x,$yorg) = @_;
+
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x);
+ unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+sub _div_use_div_64
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+ # This version works on 64 bit integers
+ my ($c,$x,$yorg) = @_;
+
+ use integer;
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi / $BASE)) * $BASE;
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi / $BASE)) * $BASE;
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+
+ # @q will accumulate the final result, $q contains the current computed
+ # part of the final result
+
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd / $BASE)) * $BASE;
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x); unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+sub _div_use_div
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+ my ($c,$x,$yorg) = @_;
+
+ # the general div algorithmn here is about O(N*N) and thus quite slow, so
+ # we first check for some special cases and use shortcuts to handle them.
+
+ # This works, because we store the numbers in a chunked format where each
+ # element contains 5..7 digits (depending on system).
+
+ # if both numbers have only one element:
+ if (@$x == 1 && @$yorg == 1)
+ {
+ # shortcut, $yorg and $x are two small numbers
+ if (wantarray)
+ {
+ my $r = [ $x->[0] % $yorg->[0] ];
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return ($x,$r);
+ }
+ else
+ {
+ $x->[0] = int($x->[0] / $yorg->[0]);
+ return $x;
+ }
+ }
+ # if x has more than one, but y has only one element:
+ if (@$yorg == 1)
+ {
+ my $rem;
+ $rem = _mod($c,[ @$x ],$yorg) if wantarray;
+
+ # shortcut, $y is < $BASE
+ my $j = scalar @$x; my $r = 0;
+ my $y = $yorg->[0]; my $b;
+ while ($j-- > 0)
+ {
+ $b = $r * $BASE + $x->[$j];
+ $x->[$j] = int($b/$y);
+ $r = $b % $y;
+ }
+ pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero
+ return ($x,$rem) if wantarray;
+ return $x;
+ }
+ # now x and y have more than one element
+
+ # check whether y has more elements than x, if yet, the result will be 0
+ if (@$yorg > @$x)
+ {
+ my $rem;
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to original array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x; # only x, which is [0] now
+ }
+ # check whether the numbers have the same number of elements, in that case
+ # the result will fit into one element and can be computed efficiently
+ if (@$yorg == @$x)
+ {
+ my $rem;
+ # if $yorg has more digits than $x (it's leading element is longer than
+ # the one from $x), the result will also be 0:
+ if (length(int($yorg->[-1])) > length(int($x->[-1])))
+ {
+ $rem = [@$x] if wantarray; # make copy
+ splice (@$x,1); # keep ref to org array
+ $x->[0] = 0; # set to 0
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # now calculate $x / $yorg
+
+ if (length(int($yorg->[-1])) == length(int($x->[-1])))
+ {
+ # same length, so make full compare
+
+ my $a = 0; my $j = scalar @$x - 1;
+ # manual way (abort if unequal, good for early ne)
+ while ($j >= 0)
+ {
+ last if ($a = $x->[$j] - $yorg->[$j]); $j--;
+ }
+ # $a contains the result of the compare between X and Y
+ # a < 0: x < y, a == 0: x == y, a > 0: x > y
+ if ($a <= 0)
+ {
+ $rem = [ 0 ]; # a = 0 => x == y => rem 0
+ $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x
+ splice(@$x,1); # keep single element
+ $x->[0] = 0; # if $a < 0
+ $x->[0] = 1 if $a == 0; # $x == $y
+ return ($x,$rem) if wantarray; # including remainder?
+ return $x;
+ }
+ # $x >= $y, so proceed normally
+
+ }
+ }
+
+ # all other cases:
+
+ my $y = [ @$yorg ]; # always make copy to preserve
+
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1,@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi / $BASE)) * $BASE;
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi / $BASE)) * $BASE;
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+
+ # @q will accumulate the final result, $q contains the current computed
+ # part of the final result
+
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*$BASE+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd / $BASE)) * $BASE;
+ $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= $BASE
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE));
+ }
+ }
+ }
+ pop(@$x); unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ my $d = \@d;
+ __strip_zeros($x);
+ __strip_zeros($d);
+ return ($x,$d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ $x;
+ }
+
+##############################################################################
+# testing
+
+sub _acmp
+ {
+ # internal absolute post-normalized compare (ignore signs)
+ # ref to array, ref to array, return <0, 0, >0
+ # arrays must have at least one entry; this is not checked for
+ my ($c,$cx,$cy) = @_;
+
+ # shortcut for short numbers
+ return (($cx->[0] <=> $cy->[0]) <=> 0)
+ if scalar @$cx == scalar @$cy && scalar @$cx == 1;
+
+ # fast comp based on number of array elements (aka pseudo-length)
+ my $lxy = (scalar @$cx - scalar @$cy)
+ # or length of first element if same number of elements (aka difference 0)
+ ||
+ # need int() here because sometimes the last element is '00018' vs '18'
+ (length(int($cx->[-1])) - length(int($cy->[-1])));
+ return -1 if $lxy < 0; # already differs, ret
+ return 1 if $lxy > 0; # ditto
+
+ # manual way (abort if unequal, good for early ne)
+ my $a; my $j = scalar @$cx;
+ while (--$j >= 0)
+ {
+ last if ($a = $cx->[$j] - $cy->[$j]);
+ }
+ $a <=> 0;
+ }
+
+sub _len
+ {
+ # compute number of digits in base 10
+
+ # int() because add/sub sometimes leaves strings (like '00005') instead of
+ # '5' in this place, thus causing length() to report wrong length
+ my $cx = $_[1];
+
+ (@$cx-1)*$BASE_LEN+length(int($cx->[-1]));
+ }
+
+sub _digit
+ {
+ # return the nth digit, negative values count backward
+ # zero is rightmost, so _digit(123,0) will give 3
+ my ($c,$x,$n) = @_;
+
+ my $len = _len('',$x);
+
+ $n = $len+$n if $n < 0; # -1 last, -2 second-to-last
+ $n = abs($n); # if negative was too big
+ $len--; $n = $len if $n > $len; # n to big?
+
+ my $elem = int($n / $BASE_LEN); # which array element
+ my $digit = $n % $BASE_LEN; # which digit in this element
+ $elem = '0' x $BASE_LEN . @$x[$elem]; # get element padded with 0's
+ substr($elem,-$digit-1,1);
+ }
+
+sub _zeros
+ {
+ # return amount of trailing zeros in decimal
+ # check each array elem in _m for having 0 at end as long as elem == 0
+ # Upon finding a elem != 0, stop
+ my $x = $_[1];
+
+ return 0 if scalar @$x == 1 && $x->[0] == 0;
+
+ my $zeros = 0; my $elem;
+ foreach my $e (@$x)
+ {
+ if ($e != 0)
+ {
+ $elem = "$e"; # preserve x
+ $elem =~ s/.*?(0*$)/$1/; # strip anything not zero
+ $zeros *= $BASE_LEN; # elems * 5
+ $zeros += length($elem); # count trailing zeros
+ last; # early out
+ }
+ $zeros ++; # real else branch: 50% slower!
+ }
+ $zeros;
+ }
+
+##############################################################################
+# _is_* routines
+
+sub _is_zero
+ {
+ # return true if arg is zero
+ (((scalar @{$_[1]} == 1) && ($_[1]->[0] == 0))) <=> 0;
+ }
+
+sub _is_even
+ {
+ # return true if arg is even
+ (!($_[1]->[0] & 1)) <=> 0;
+ }
+
+sub _is_odd
+ {
+ # return true if arg is even
+ (($_[1]->[0] & 1)) <=> 0;
+ }
+
+sub _is_one
+ {
+ # return true if arg is one
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 1) <=> 0;
+ }
+
+sub _is_two
+ {
+ # return true if arg is two
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 2) <=> 0;
+ }
+
+sub _is_ten
+ {
+ # return true if arg is ten
+ (scalar @{$_[1]} == 1) && ($_[1]->[0] == 10) <=> 0;
+ }
+
+sub __strip_zeros
+ {
+ # internal normalization function that strips leading zeros from the array
+ # args: ref to array
+ my $s = shift;
+
+ my $cnt = scalar @$s; # get count of parts
+ my $i = $cnt-1;
+ push @$s,0 if $i < 0; # div might return empty results, so fix it
+
+ return $s if @$s == 1; # early out
+
+ #print "strip: cnt $cnt i $i\n";
+ # '0', '3', '4', '0', '0',
+ # 0 1 2 3 4
+ # cnt = 5, i = 4
+ # i = 4
+ # i = 3
+ # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
+ # >= 1: skip first part (this can be zero)
+ while ($i > 0) { last if $s->[$i] != 0; $i--; }
+ $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
+ $s;
+ }
+
+###############################################################################
+# check routine to test internal state for corruptions
+
+sub _check
+ {
+ # used by the test suite
+ my $x = $_[1];
+
+ return "$x is not a reference" if !ref($x);
+
+ # are all parts are valid?
+ my $i = 0; my $j = scalar @$x; my ($e,$try);
+ while ($i < $j)
+ {
+ $e = $x->[$i]; $e = 'undef' unless defined $e;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
+ last if $e !~ /^[+]?[0-9]+$/;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)";
+ last if "$e" !~ /^[+]?[0-9]+$/;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)";
+ last if '' . "$e" !~ /^[+]?[0-9]+$/;
+ $try = ' < 0 || >= $BASE; '."($x, $e)";
+ last if $e <0 || $e >= $BASE;
+ # this test is disabled, since new/bnorm and certain ops (like early out
+ # in add/sub) are allowed/expected to leave '00000' in some elements
+ #$try = '=~ /^00+/; '."($x, $e)";
+ #last if $e =~ /^00+/;
+ $i++;
+ }
+ return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
+ 0;
+ }
+
+
+###############################################################################
+
+sub _mod
+ {
+ # if possible, use mod shortcut
+ my ($c,$x,$yo) = @_;
+
+ # slow way since $y to big
+ if (scalar @$yo > 1)
+ {
+ my ($xo,$rem) = _div($c,$x,$yo);
+ return $rem;
+ }
+
+ my $y = $yo->[0];
+ # both are single element arrays
+ if (scalar @$x == 1)
+ {
+ $x->[0] %= $y;
+ return $x;
+ }
+
+ # @y is a single element, but @x has more than one element
+ my $b = $BASE % $y;
+ if ($b == 0)
+ {
+ # when BASE % Y == 0 then (B * BASE) % Y == 0
+ # (B * BASE) % $y + A % Y => A % Y
+ # so need to consider only last element: O(1)
+ $x->[0] %= $y;
+ }
+ elsif ($b == 1)
+ {
+ # else need to go through all elements: O(N), but loop is a bit simplified
+ my $r = 0;
+ foreach (@$x)
+ {
+ $r = ($r + $_) % $y; # not much faster, but heh...
+ #$r += $_ % $y; $r %= $y;
+ }
+ $r = 0 if $r == $y;
+ $x->[0] = $r;
+ }
+ else
+ {
+ # else need to go through all elements: O(N)
+ my $r = 0; my $bm = 1;
+ foreach (@$x)
+ {
+ $r = ($_ * $bm + $r) % $y;
+ $bm = ($bm * $b) % $y;
+
+ #$r += ($_ % $y) * $bm;
+ #$bm *= $b;
+ #$bm %= $y;
+ #$r %= $y;
+ }
+ $r = 0 if $r == $y;
+ $x->[0] = $r;
+ }
+ splice (@$x,1); # keep one element of $x
+ $x;
+ }
+
+##############################################################################
+# shifts
+
+sub _rsft
+ {
+ my ($c,$x,$y,$n) = @_;
+
+ if ($n != 10)
+ {
+ $n = _new($c,$n); return _div($c,$x, _pow($c,$n,$y));
+ }
+
+ # shortcut (faster) for shifting by 10)
+ # multiples of $BASE_LEN
+ my $dst = 0; # destination
+ my $src = _num($c,$y); # as normal int
+ my $xlen = (@$x-1)*$BASE_LEN+length(int($x->[-1])); # len of x in digits
+ if ($src >= $xlen or ($src == $xlen and ! defined $x->[1]))
+ {
+ # 12345 67890 shifted right by more than 10 digits => 0
+ splice (@$x,1); # leave only one element
+ $x->[0] = 0; # set to zero
+ return $x;
+ }
+ my $rem = $src % $BASE_LEN; # remainder to shift
+ $src = int($src / $BASE_LEN); # source
+ if ($rem == 0)
+ {
+ splice (@$x,0,$src); # even faster, 38.4 => 39.3
+ }
+ else
+ {
+ my $len = scalar @$x - $src; # elems to go
+ my $vd; my $z = '0'x $BASE_LEN;
+ $x->[scalar @$x] = 0; # avoid || 0 test inside loop
+ while ($dst < $len)
+ {
+ $vd = $z.$x->[$src];
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem);
+ $src++;
+ $vd = substr($z.$x->[$src],-$rem,$rem) . $vd;
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
+ $x->[$dst] = int($vd);
+ $dst++;
+ }
+ splice (@$x,$dst) if $dst > 0; # kill left-over array elems
+ pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0
+ } # else rem == 0
+ $x;
+ }
+
+sub _lsft
+ {
+ my ($c,$x,$y,$n) = @_;
+
+ if ($n != 10)
+ {
+ $n = _new($c,$n); return _mul($c,$x, _pow($c,$n,$y));
+ }
+
+ # shortcut (faster) for shifting by 10) since we are in base 10eX
+ # multiples of $BASE_LEN:
+ my $src = scalar @$x; # source
+ my $len = _num($c,$y); # shift-len as normal int
+ my $rem = $len % $BASE_LEN; # remainder to shift
+ my $dst = $src + int($len/$BASE_LEN); # destination
+ my $vd; # further speedup
+ $x->[$src] = 0; # avoid first ||0 for speed
+ my $z = '0' x $BASE_LEN;
+ while ($src >= 0)
+ {
+ $vd = $x->[$src]; $vd = $z.$vd;
+ $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem);
+ $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem;
+ $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN;
+ $x->[$dst] = int($vd);
+ $dst--; $src--;
+ }
+ # set lowest parts to 0
+ while ($dst >= 0) { $x->[$dst--] = 0; }
+ # fix spurios last zero element
+ splice @$x,-1 if $x->[-1] == 0;
+ $x;
+ }
+
+sub _pow
+ {
+ # power of $x to $y
+ # ref to array, ref to array, return ref to array
+ my ($c,$cx,$cy) = @_;
+
+ if (scalar @$cy == 1 && $cy->[0] == 0)
+ {
+ splice (@$cx,1); $cx->[0] = 1; # y == 0 => x => 1
+ return $cx;
+ }
+ if ((scalar @$cx == 1 && $cx->[0] == 1) || # x == 1
+ (scalar @$cy == 1 && $cy->[0] == 1)) # or y == 1
+ {
+ return $cx;
+ }
+ if (scalar @$cx == 1 && $cx->[0] == 0)
+ {
+ splice (@$cx,1); $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0)
+ return $cx;
+ }
+
+ my $pow2 = _one();
+
+ my $y_bin = _as_bin($c,$cy); $y_bin =~ s/^0b//;
+ my $len = length($y_bin);
+ while (--$len > 0)
+ {
+ _mul($c,$pow2,$cx) if substr($y_bin,$len,1) eq '1'; # is odd?
+ _mul($c,$cx,$cx);
+ }
+
+ _mul($c,$cx,$pow2);
+ $cx;
+ }
+
+sub _nok
+ {
+ # n over k
+ # ref to array, return ref to array
+ my ($c,$n,$k) = @_;
+
+ # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
+ # ( - ) = --------- = --------------- = ---------
+ # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
+
+ # compute n - k + 2 (so we start with 5 in the example above)
+ my $x = _copy($c,$n);
+
+ _sub($c,$n,$k);
+ if (!_is_one($c,$n))
+ {
+ _inc($c,$n);
+ my $f = _copy($c,$n); _inc($c,$f); # n = 5, f = 6, d = 2
+ my $d = _two($c);
+ while (_acmp($c,$f,$x) <= 0) # f < n ?
+ {
+ # n = (n * f / d) == 5 * 6 / 2 => n == 3
+ $n = _mul($c,$n,$f); $n = _div($c,$n,$d);
+ # f = 7, d = 3
+ _inc($c,$f); _inc($c,$d);
+ }
+ }
+ else
+ {
+ # keep ref to $n and set it to 1
+ splice (@$n,1); $n->[0] = 1;
+ }
+ $n;
+ }
+
+my @factorials = (
+ 1,
+ 1,
+ 2,
+ 2*3,
+ 2*3*4,
+ 2*3*4*5,
+ 2*3*4*5*6,
+ 2*3*4*5*6*7,
+);
+
+sub _fac
+ {
+ # factorial of $x
+ # ref to array, return ref to array
+ my ($c,$cx) = @_;
+
+ if ((@$cx == 1) && ($cx->[0] <= 7))
+ {
+ $cx->[0] = $factorials[$cx->[0]]; # 0 => 1, 1 => 1, 2 => 2 etc.
+ return $cx;
+ }
+
+ if ((@$cx == 1) && # we do this only if $x >= 12 and $x <= 7000
+ ($cx->[0] >= 12 && $cx->[0] < 7000))
+ {
+
+ # Calculate (k-j) * (k-j+1) ... k .. (k+j-1) * (k + j)
+ # See http://blogten.blogspot.com/2007/01/calculating-n.html
+ # The above series can be expressed as factors:
+ # k * k - (j - i) * 2
+ # We cache k*k, and calculate (j * j) as the sum of the first j odd integers
+
+ # This will not work when N exceeds the storage of a Perl scalar, however,
+ # in this case the algorithm would be way to slow to terminate, anyway.
+
+ # As soon as the last element of $cx is 0, we split it up and remember
+ # how many zeors we got so far. The reason is that n! will accumulate
+ # zeros at the end rather fast.
+ my $zero_elements = 0;
+
+ # If n is even, set n = n -1
+ my $k = _num($c,$cx); my $even = 1;
+ if (($k & 1) == 0)
+ {
+ $even = $k; $k --;
+ }
+ # set k to the center point
+ $k = ($k + 1) / 2;
+# print "k $k even: $even\n";
+ # now calculate k * k
+ my $k2 = $k * $k;
+ my $odd = 1; my $sum = 1;
+ my $i = $k - 1;
+ # keep reference to x
+ my $new_x = _new($c, $k * $even);
+ @$cx = @$new_x;
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+# print STDERR "x = ", _str($c,$cx),"\n";
+ my $BASE2 = int(sqrt($BASE))-1;
+ my $j = 1;
+ while ($j <= $i)
+ {
+ my $m = ($k2 - $sum); $odd += 2; $sum += $odd; $j++;
+ while ($j <= $i && ($m < $BASE2) && (($k2 - $sum) < $BASE2))
+ {
+ $m *= ($k2 - $sum);
+ $odd += 2; $sum += $odd; $j++;
+# print STDERR "\n k2 $k2 m $m sum $sum odd $odd\n"; sleep(1);
+ }
+ if ($m < $BASE)
+ {
+ _mul($c,$cx,[$m]);
+ }
+ else
+ {
+ _mul($c,$cx,$c->_new($m));
+ }
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+# print STDERR "Calculate $k2 - $sum = $m (x = ", _str($c,$cx),")\n";
+ }
+ # multiply in the zeros again
+ unshift @$cx, (0) x $zero_elements;
+ return $cx;
+ }
+
+ # go forward until $base is exceeded
+ # limit is either $x steps (steps == 100 means a result always too high) or
+ # $base.
+ my $steps = 100; $steps = $cx->[0] if @$cx == 1;
+ my $r = 2; my $cf = 3; my $step = 2; my $last = $r;
+ while ($r*$cf < $BASE && $step < $steps)
+ {
+ $last = $r; $r *= $cf++; $step++;
+ }
+ if ((@$cx == 1) && $step == $cx->[0])
+ {
+ # completely done, so keep reference to $x and return
+ $cx->[0] = $r;
+ return $cx;
+ }
+
+ # now we must do the left over steps
+ my $n; # steps still to do
+ if (scalar @$cx == 1)
+ {
+ $n = $cx->[0];
+ }
+ else
+ {
+ $n = _copy($c,$cx);
+ }
+
+ # Set $cx to the last result below $BASE (but keep ref to $x)
+ $cx->[0] = $last; splice (@$cx,1);
+ # As soon as the last element of $cx is 0, we split it up and remember
+ # how many zeors we got so far. The reason is that n! will accumulate
+ # zeros at the end rather fast.
+ my $zero_elements = 0;
+
+ # do left-over steps fit into a scalar?
+ if (ref $n eq 'ARRAY')
+ {
+ # No, so use slower inc() & cmp()
+ # ($n is at least $BASE here)
+ my $base_2 = int(sqrt($BASE)) - 1;
+ #print STDERR "base_2: $base_2\n";
+ while ($step < $base_2)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ $step = [$step];
+ while (_acmp($c,$step,$n) <= 0)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ _mul($c,$cx,$step); _inc($c,$step);
+ }
+ }
+ else
+ {
+ # Yes, so we can speed it up slightly
+
+# print "# left over steps $n\n";
+
+ my $base_4 = int(sqrt(sqrt($BASE))) - 2;
+ #print STDERR "base_4: $base_4\n";
+ my $n4 = $n - 4;
+ while ($step < $n4 && $step < $base_4)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2; $b *= $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ my $base_2 = int(sqrt($BASE)) - 1;
+ my $n2 = $n - 2;
+ #print STDERR "base_2: $base_2\n";
+ while ($step < $n2 && $step < $base_2)
+ {
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ my $b = $step * ($step + 1); $step += 2;
+ _mul($c,$cx,[$b]);
+ }
+ # do what's left over
+ while ($step <= $n)
+ {
+ _mul($c,$cx,[$step]); $step++;
+ if ($cx->[0] == 0)
+ {
+ $zero_elements ++; shift @$cx;
+ }
+ }
+ }
+ # multiply in the zeros again
+ unshift @$cx, (0) x $zero_elements;
+ $cx; # return result
+ }
+
+#############################################################################
+
+sub _log_int
+ {
+ # calculate integer log of $x to base $base
+ # ref to array, ref to array - return ref to array
+ my ($c,$x,$base) = @_;
+
+ # X == 0 => NaN
+ return if (scalar @$x == 1 && $x->[0] == 0);
+ # BASE 0 or 1 => NaN
+ return if (scalar @$base == 1 && $base->[0] < 2);
+ my $cmp = _acmp($c,$x,$base); # X == BASE => 1
+ if ($cmp == 0)
+ {
+ splice (@$x,1); $x->[0] = 1;
+ return ($x,1)
+ }
+ # X < BASE
+ if ($cmp < 0)
+ {
+ splice (@$x,1); $x->[0] = 0;
+ return ($x,undef);
+ }
+
+ my $x_org = _copy($c,$x); # preserve x
+ splice(@$x,1); $x->[0] = 1; # keep ref to $x
+
+ # Compute a guess for the result based on:
+ # $guess = int ( length_in_base_10(X) / ( log(base) / log(10) ) )
+ my $len = _len($c,$x_org);
+ my $log = log($base->[-1]) / log(10);
+
+ # for each additional element in $base, we add $BASE_LEN to the result,
+ # based on the observation that log($BASE,10) is BASE_LEN and
+ # log(x*y) == log(x) + log(y):
+ $log += ((scalar @$base)-1) * $BASE_LEN;
+
+ # calculate now a guess based on the values obtained above:
+ my $res = int($len / $log);
+
+ $x->[0] = $res;
+ my $trial = _pow ($c, _copy($c, $base), $x);
+ my $a = _acmp($c,$trial,$x_org);
+
+# print STDERR "# trial ", _str($c,$x)," was: $a (0 = exact, -1 too small, +1 too big)\n";
+
+ # found an exact result?
+ return ($x,1) if $a == 0;
+
+ if ($a > 0)
+ {
+ # or too big
+ _div($c,$trial,$base); _dec($c, $x);
+ while (($a = _acmp($c,$trial,$x_org)) > 0)
+ {
+# print STDERR "# big _log_int at ", _str($c,$x), "\n";
+ _div($c,$trial,$base); _dec($c, $x);
+ }
+ # result is now exact (a == 0), or too small (a < 0)
+ return ($x, $a == 0 ? 1 : 0);
+ }
+
+ # else: result was to small
+ _mul($c,$trial,$base);
+
+ # did we now get the right result?
+ $a = _acmp($c,$trial,$x_org);
+
+ if ($a == 0) # yes, exactly
+ {
+ _inc($c, $x);
+ return ($x,1);
+ }
+ return ($x,0) if $a > 0;
+
+ # Result still too small (we should come here only if the estimate above
+ # was very off base):
+
+ # Now let the normal trial run obtain the real result
+ # Simple loop that increments $x by 2 in each step, possible overstepping
+ # the real result
+
+ my $base_mul = _mul($c, _copy($c,$base), $base); # $base * $base
+
+ while (($a = _acmp($c,$trial,$x_org)) < 0)
+ {
+# print STDERR "# small _log_int at ", _str($c,$x), "\n";
+ _mul($c,$trial,$base_mul); _add($c, $x, [2]);
+ }
+
+ my $exact = 1;
+ if ($a > 0)
+ {
+ # overstepped the result
+ _dec($c, $x);
+ _div($c,$trial,$base);
+ $a = _acmp($c,$trial,$x_org);
+ if ($a > 0)
+ {
+ _dec($c, $x);
+ }
+ $exact = 0 if $a != 0; # a = -1 => not exact result, a = 0 => exact
+ }
+
+ ($x,$exact); # return result
+ }
+
+# for debugging:
+ use constant DEBUG => 0;
+ my $steps = 0;
+ sub steps { $steps };
+
+sub _sqrt
+ {
+ # square-root of $x in place
+ # Compute a guess of the result (by rule of thumb), then improve it via
+ # Newton's method.
+ my ($c,$x) = @_;
+
+ if (scalar @$x == 1)
+ {
+ # fits into one Perl scalar, so result can be computed directly
+ $x->[0] = int(sqrt($x->[0]));
+ return $x;
+ }
+ my $y = _copy($c,$x);
+ # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess
+ # since our guess will "grow"
+ my $l = int((_len($c,$x)-1) / 2);
+
+ my $lastelem = $x->[-1]; # for guess
+ my $elems = scalar @$x - 1;
+ # not enough digits, but could have more?
+ if ((length($lastelem) <= 3) && ($elems > 1))
+ {
+ # right-align with zero pad
+ my $len = length($lastelem) & 1;
+ print "$lastelem => " if DEBUG;
+ $lastelem .= substr($x->[-2] . '0' x $BASE_LEN,0,$BASE_LEN);
+ # former odd => make odd again, or former even to even again
+ $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len;
+ print "$lastelem\n" if DEBUG;
+ }
+
+ # construct $x (instead of _lsft($c,$x,$l,10)
+ my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5)
+ $l = int($l / $BASE_LEN);
+ print "l = $l " if DEBUG;
+
+ splice @$x,$l; # keep ref($x), but modify it
+
+ # we make the first part of the guess not '1000...0' but int(sqrt($lastelem))
+ # that gives us:
+ # 14400 00000 => sqrt(14400) => guess first digits to be 120
+ # 144000 000000 => sqrt(144000) => guess 379
+
+ print "$lastelem (elems $elems) => " if DEBUG;
+ $lastelem = $lastelem / 10 if ($elems & 1 == 1); # odd or even?
+ my $g = sqrt($lastelem); $g =~ s/\.//; # 2.345 => 2345
+ $r -= 1 if $elems & 1 == 0; # 70 => 7
+
+ # padd with zeros if result is too short
+ $x->[$l--] = int(substr($g . '0' x $r,0,$r+1));
+ print "now ",$x->[-1] if DEBUG;
+ print " would have been ", int('1' . '0' x $r),"\n" if DEBUG;
+
+ # If @$x > 1, we could compute the second elem of the guess, too, to create
+ # an even better guess. Not implemented yet. Does it improve performance?
+ $x->[$l--] = 0 while ($l >= 0); # all other digits of guess are zero
+
+ print "start x= ",_str($c,$x),"\n" if DEBUG;
+ my $two = _two();
+ my $last = _zero();
+ my $lastlast = _zero();
+ $steps = 0 if DEBUG;
+ while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0)
+ {
+ $steps++ if DEBUG;
+ $lastlast = _copy($c,$last);
+ $last = _copy($c,$x);
+ _add($c,$x, _div($c,_copy($c,$y),$x));
+ _div($c,$x, $two );
+ print " x= ",_str($c,$x),"\n" if DEBUG;
+ }
+ print "\nsteps in sqrt: $steps, " if DEBUG;
+ _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0; # overshot?
+ print " final ",$x->[-1],"\n" if DEBUG;
+ $x;
+ }
+
+sub _root
+ {
+ # take n'th root of $x in place (n >= 3)
+ my ($c,$x,$n) = @_;
+
+ if (scalar @$x == 1)
+ {
+ if (scalar @$n > 1)
+ {
+ # result will always be smaller than 2 so trunc to 1 at once
+ $x->[0] = 1;
+ }
+ else
+ {
+ # fits into one Perl scalar, so result can be computed directly
+ # cannot use int() here, because it rounds wrongly (try
+ # (81 ** 3) ** (1/3) to see what I mean)
+ #$x->[0] = int( $x->[0] ** (1 / $n->[0]) );
+ # round to 8 digits, then truncate result to integer
+ $x->[0] = int ( sprintf ("%.8f", $x->[0] ** (1 / $n->[0]) ) );
+ }
+ return $x;
+ }
+
+ # we know now that X is more than one element long
+
+ # if $n is a power of two, we can repeatedly take sqrt($X) and find the
+ # proper result, because sqrt(sqrt($x)) == root($x,4)
+ my $b = _as_bin($c,$n);
+ if ($b =~ /0b1(0+)$/)
+ {
+ my $count = CORE::length($1); # 0b100 => len('00') => 2
+ my $cnt = $count; # counter for loop
+ unshift (@$x, 0); # add one element, together with one
+ # more below in the loop this makes 2
+ while ($cnt-- > 0)
+ {
+ # 'inflate' $X by adding one element, basically computing
+ # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for result
+ # since len(sqrt($X)) approx == len($x) / 2.
+ unshift (@$x, 0);
+ # calculate sqrt($x), $x is now one element to big, again. In the next
+ # round we make that two, again.
+ _sqrt($c,$x);
+ }
+ # $x is now one element to big, so truncate result by removing it
+ splice (@$x,0,1);
+ }
+ else
+ {
+ # trial computation by starting with 2,4,8,16 etc until we overstep
+ my $step;
+ my $trial = _two();
+
+ # while still to do more than X steps
+ do
+ {
+ $step = _two();
+ while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
+ {
+ _mul ($c, $step, [2]);
+ _add ($c, $trial, $step);
+ }
+
+ # hit exactly?
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) == 0)
+ {
+ @$x = @$trial; # make copy while preserving ref to $x
+ return $x;
+ }
+ # overstepped, so go back on step
+ _sub($c, $trial, $step);
+ } while (scalar @$step > 1 || $step->[0] > 128);
+
+ # reset step to 2
+ $step = _two();
+ # add two, because $trial cannot be exactly the result (otherwise we would
+ # alrady have found it)
+ _add($c, $trial, $step);
+
+ # and now add more and more (2,4,6,8,10 etc)
+ while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0)
+ {
+ _add ($c, $trial, $step);
+ }
+
+ # hit not exactly? (overstepped)
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
+ {
+ _dec($c,$trial);
+ }
+
+ # hit not exactly? (overstepped)
+ # 80 too small, 81 slightly too big, 82 too big
+ if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0)
+ {
+ _dec ($c, $trial);
+ }
+
+ @$x = @$trial; # make copy while preserving ref to $x
+ return $x;
+ }
+ $x;
+ }
+
+##############################################################################
+# binary stuff
+
+sub _and
+ {
+ my ($c,$x,$y) = @_;
+
+ # the shortcut makes equal, large numbers _really_ fast, and makes only a
+ # very small performance drop for small numbers (e.g. something with less
+ # than 32 bit) Since we optimize for large numbers, this is enabled.
+ return $x if _acmp($c,$x,$y) == 0; # shortcut
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $AND_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+
+ # make ints() from $xr, $yr
+ # this is when the AND_BITS are greater than $BASE and is slower for
+ # small (<256 bits) numbers, but faster for large numbers. Disabled
+ # due to KISS principle
+
+# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+# _add($c,$x, _mul($c, _new( $c, ($xrr & $yrr) ), $m) );
+
+ # 0+ due to '&' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] & 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ $x;
+ }
+
+sub _xor
+ {
+ my ($c,$x,$y) = @_;
+
+ return _zero() if _acmp($c,$x,$y) == 0; # shortcut (see -and)
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $XOR_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+ # make ints() from $xr, $yr (see _and())
+ #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+ #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+ #_add($c,$x, _mul($c, _new( $c, ($xrr ^ $yrr) ), $m) );
+
+ # 0+ due to '^' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] ^ 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ # the loop stops when the shorter of the two numbers is exhausted
+ # the remainder of the longer one will survive bit-by-bit, so we simple
+ # multiply-add it in
+ _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+ _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+
+ $x;
+ }
+
+sub _or
+ {
+ my ($c,$x,$y) = @_;
+
+ return $x if _acmp($c,$x,$y) == 0; # shortcut (see _and)
+
+ my $m = _one(); my ($xr,$yr);
+ my $mask = $OR_MASK;
+
+ my $x1 = $x;
+ my $y1 = _copy($c,$y); # make copy
+ $x = _zero();
+ my ($b,$xrr,$yrr);
+ use integer;
+ while (!_is_zero($c,$x1) && !_is_zero($c,$y1))
+ {
+ ($x1, $xr) = _div($c,$x1,$mask);
+ ($y1, $yr) = _div($c,$y1,$mask);
+ # make ints() from $xr, $yr (see _and())
+# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; }
+# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; }
+# _add($c,$x, _mul($c, _new( $c, ($xrr | $yrr) ), $m) );
+
+ # 0+ due to '|' doesn't work in strings
+ _add($c,$x, _mul($c, [ 0+$xr->[0] | 0+$yr->[0] ], $m) );
+ _mul($c,$m,$mask);
+ }
+ # the loop stops when the shorter of the two numbers is exhausted
+ # the remainder of the longer one will survive bit-by-bit, so we simple
+ # multiply-add it in
+ _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1);
+ _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1);
+
+ $x;
+ }
+
+sub _as_hex
+ {
+ # convert a decimal number to hex (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (handle also 0x0 case)
+ return sprintf("0x%x",$x->[0]) if @$x == 1;
+
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my ($xr, $h, $x10000);
+ if ($] >= 5.006)
+ {
+ $x10000 = [ 0x10000 ]; $h = 'h4';
+ }
+ else
+ {
+ $x10000 = [ 0x1000 ]; $h = 'h3';
+ }
+ while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x10000);
+ $es .= unpack($h,pack('V',$xr->[0]));
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0x' . $es; # return result prepended with 0x
+ }
+
+sub _as_bin
+ {
+ # convert a decimal number to bin (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (and Perl recent enough), handle also 0b0 case
+ # handle zero case for older Perls
+ if ($] <= 5.005 && @$x == 1 && $x->[0] == 0)
+ {
+ my $t = '0b0'; return $t;
+ }
+ if (@$x == 1 && $] >= 5.006)
+ {
+ my $t = sprintf("0b%b",$x->[0]);
+ return $t;
+ }
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my ($xr, $b, $x10000);
+ if ($] >= 5.006)
+ {
+ $x10000 = [ 0x10000 ]; $b = 'b16';
+ }
+ else
+ {
+ $x10000 = [ 0x1000 ]; $b = 'b12';
+ }
+ while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x10000);
+ $es .= unpack($b,pack('v',$xr->[0]));
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0b' . $es; # return result prepended with 0b
+ }
+
+sub _as_oct
+ {
+ # convert a decimal number to octal (ref to array, return ref to string)
+ my ($c,$x) = @_;
+
+ # fits into one element (handle also 0 case)
+ return sprintf("0%o",$x->[0]) if @$x == 1;
+
+ my $x1 = _copy($c,$x);
+
+ my $es = '';
+ my $xr;
+ my $x1000 = [ 0100000 ];
+ while (@$x1 != 1 || $x1->[0] != 0) # _is_zero()
+ {
+ ($x1, $xr) = _div($c,$x1,$x1000);
+ $es .= reverse sprintf("%05o", $xr->[0]);
+ }
+ $es = reverse $es;
+ $es =~ s/^[0]+//; # strip leading zeros
+ '0' . $es; # return result prepended with 0
+ }
+
+sub _from_oct
+ {
+ # convert a octal number to decimal (string, return ref to array)
+ my ($c,$os) = @_;
+
+ # for older Perls, play safe
+ my $m = [ 0100000 ];
+ my $d = 5; # 5 digits at a time
+
+ my $mul = _one();
+ my $x = _zero();
+
+ my $len = int( (length($os)-1)/$d ); # $d digit parts, w/o the '0'
+ my $val; my $i = -$d;
+ while ($len >= 0)
+ {
+ $val = substr($os,$i,$d); # get oct digits
+ $val = CORE::oct($val);
+ $i -= $d; $len --;
+ my $adder = [ $val ];
+ _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
+ _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
+ }
+ $x;
+ }
+
+sub _from_hex
+ {
+ # convert a hex number to decimal (string, return ref to array)
+ my ($c,$hs) = @_;
+
+ my $m = _new($c, 0x10000000); # 28 bit at a time (<32 bit!)
+ my $d = 7; # 7 digits at a time
+ if ($] <= 5.006)
+ {
+ # for older Perls, play safe
+ $m = [ 0x10000 ]; # 16 bit at a time (<32 bit!)
+ $d = 4; # 4 digits at a time
+ }
+
+ my $mul = _one();
+ my $x = _zero();
+
+ my $len = int( (length($hs)-2)/$d ); # $d digit parts, w/o the '0x'
+ my $val; my $i = -$d;
+ while ($len >= 0)
+ {
+ $val = substr($hs,$i,$d); # get hex digits
+ $val =~ s/^0x// if $len == 0; # for last part only because
+ $val = CORE::hex($val); # hex does not like wrong chars
+ $i -= $d; $len --;
+ my $adder = [ $val ];
+ # if the resulting number was to big to fit into one element, create a
+ # two-element version (bug found by Mark Lakata - Thanx!)
+ if (CORE::length($val) > $BASE_LEN)
+ {
+ $adder = _new($c,$val);
+ }
+ _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0;
+ _mul ($c, $mul, $m ) if $len >= 0; # skip last mul
+ }
+ $x;
+ }
+
+sub _from_bin
+ {
+ # convert a hex number to decimal (string, return ref to array)
+ my ($c,$bs) = @_;
+
+ # instead of converting X (8) bit at a time, it is faster to "convert" the
+ # number to hex, and then call _from_hex.
+
+ my $hs = $bs;
+ $hs =~ s/^[+-]?0b//; # remove sign and 0b
+ my $l = length($hs); # bits
+ $hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0
+ my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex
+
+ $c->_from_hex($h);
+ }
+
+##############################################################################
+# special modulus functions
+
+sub _modinv
+ {
+ # modular inverse
+ my ($c,$x,$y) = @_;
+
+ my $u = _zero($c); my $u1 = _one($c);
+ my $a = _copy($c,$y); my $b = _copy($c,$x);
+
+ # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the
+ # result ($u) at the same time. See comments in BigInt for why this works.
+ my $q;
+ ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
+ my $sign = 1;
+ while (!_is_zero($c,$b))
+ {
+ my $t = _add($c, # step 2:
+ _mul($c,_copy($c,$u1), $q) , # t = u1 * q
+ $u ); # + u
+ $u = $u1; # u = u1, u1 = t
+ $u1 = $t;
+ $sign = -$sign;
+ ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1
+ }
+
+ # if the gcd is not 1, then return NaN
+ return (undef,undef) unless _is_one($c,$a);
+
+ ($u1, $sign == 1 ? '+' : '-');
+ }
+
+sub _modpow
+ {
+ # modulus of power ($x ** $y) % $z
+ my ($c,$num,$exp,$mod) = @_;
+
+ # in the trivial case,
+ if (_is_one($c,$mod))
+ {
+ splice @$num,0,1; $num->[0] = 0;
+ return $num;
+ }
+ if ((scalar @$num == 1) && (($num->[0] == 0) || ($num->[0] == 1)))
+ {
+ $num->[0] = 1;
+ return $num;
+ }
+
+# $num = _mod($c,$num,$mod); # this does not make it faster
+
+ my $acc = _copy($c,$num); my $t = _one();
+
+ my $expbin = _as_bin($c,$exp); $expbin =~ s/^0b//;
+ my $len = length($expbin);
+ while (--$len >= 0)
+ {
+ if ( substr($expbin,$len,1) eq '1') # is_odd
+ {
+ _mul($c,$t,$acc);
+ $t = _mod($c,$t,$mod);
+ }
+ _mul($c,$acc,$acc);
+ $acc = _mod($c,$acc,$mod);
+ }
+ @$num = @$t;
+ $num;
+ }
+
+sub _gcd
+ {
+ # greatest common divisor
+ my ($c,$x,$y) = @_;
+
+ while ( (scalar @$y != 1) || ($y->[0] != 0) ) # while ($y != 0)
+ {
+ my $t = _copy($c,$y);
+ $y = _mod($c, $x, $y);
+ $x = $t;
+ }
+ $x;
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigInt::Calc - Pure Perl module to support Math::BigInt
+
+=head1 SYNOPSIS
+
+Provides support for big integer calculations. Not intended to be used by other
+modules. Other modules which sport the same functions can also be used to support
+Math::BigInt, like Math::BigInt::GMP or Math::BigInt::Pari.
+
+=head1 DESCRIPTION
+
+In order to allow for multiple big integer libraries, Math::BigInt was
+rewritten to use library modules for core math routines. Any module which
+follows the same API as this can be used instead by using the following:
+
+ use Math::BigInt lib => 'libname';
+
+'libname' is either the long name ('Math::BigInt::Pari'), or only the short
+version like 'Pari'.
+
+=head1 STORAGE
+
+=head1 METHODS
+
+The following functions MUST be defined in order to support the use by
+Math::BigInt v1.70 or later:
+
+ api_version() return API version, 1 for v1.70, 2 for v1.83
+ _new(string) return ref to new object from ref to decimal string
+ _zero() return a new object with value 0
+ _one() return a new object with value 1
+ _two() return a new object with value 2
+ _ten() return a new object with value 10
+
+ _str(obj) return ref to a string representing the object
+ _num(obj) returns a Perl integer/floating point number
+ NOTE: because of Perl numeric notation defaults,
+ the _num'ified obj may lose accuracy due to
+ machine-dependent floating point size limitations
+
+ _add(obj,obj) Simple addition of two objects
+ _mul(obj,obj) Multiplication of two objects
+ _div(obj,obj) Division of the 1st object by the 2nd
+ In list context, returns (result,remainder).
+ NOTE: this is integer math, so no
+ fractional part will be returned.
+ The second operand will be not be 0, so no need to
+ check for that.
+ _sub(obj,obj) Simple subtraction of 1 object from another
+ a third, optional parameter indicates that the params
+ are swapped. In this case, the first param needs to
+ be preserved, while you can destroy the second.
+ sub (x,y,1) => return x - y and keep x intact!
+ _dec(obj) decrement object by one (input is guaranteed to be > 0)
+ _inc(obj) increment object by one
+
+
+ _acmp(obj,obj) <=> operator for objects (return -1, 0 or 1)
+
+ _len(obj) returns count of the decimal digits of the object
+ _digit(obj,n) returns the n'th decimal digit of object
+
+ _is_one(obj) return true if argument is 1
+ _is_two(obj) return true if argument is 2
+ _is_ten(obj) return true if argument is 10
+ _is_zero(obj) return true if argument is 0
+ _is_even(obj) return true if argument is even (0,2,4,6..)
+ _is_odd(obj) return true if argument is odd (1,3,5,7..)
+
+ _copy return a ref to a true copy of the object
+
+ _check(obj) check whether internal representation is still intact
+ return 0 for ok, otherwise error message as string
+
+ _from_hex(str) return new object from a hexadecimal string
+ _from_bin(str) return new object from a binary string
+ _from_oct(str) return new object from an octal string
+
+ _as_hex(str) return string containing the value as
+ unsigned hex string, with the '0x' prepended.
+ Leading zeros must be stripped.
+ _as_bin(str) Like as_hex, only as binary string containing only
+ zeros and ones. Leading zeros must be stripped and a
+ '0b' must be prepended.
+
+ _rsft(obj,N,B) shift object in base B by N 'digits' right
+ _lsft(obj,N,B) shift object in base B by N 'digits' left
+
+ _xor(obj1,obj2) XOR (bit-wise) object 1 with object 2
+ Note: XOR, AND and OR pad with zeros if size mismatches
+ _and(obj1,obj2) AND (bit-wise) object 1 with object 2
+ _or(obj1,obj2) OR (bit-wise) object 1 with object 2
+
+ _mod(obj1,obj2) Return remainder of div of the 1st by the 2nd object
+ _sqrt(obj) return the square root of object (truncated to int)
+ _root(obj) return the n'th (n >= 3) root of obj (truncated to int)
+ _fac(obj) return factorial of object 1 (1*2*3*4..)
+ _pow(obj1,obj2) return object 1 to the power of object 2
+ return undef for NaN
+ _zeros(obj) return number of trailing decimal zeros
+ _modinv return inverse modulus
+ _modpow return modulus of power ($x ** $y) % $z
+ _log_int(X,N) calculate integer log() of X in base N
+ X >= 0, N >= 0 (return undef for NaN)
+ returns (RESULT, EXACT) where EXACT is:
+ 1 : result is exactly RESULT
+ 0 : result was truncated to RESULT
+ undef : unknown whether result is exactly RESULT
+ _gcd(obj,obj) return Greatest Common Divisor of two objects
+
+The following functions are REQUIRED for an api_version of 2 or greater:
+
+ _1ex($x) create the number 1Ex where x >= 0
+ _alen(obj) returns approximate count of the decimal digits of the
+ object. This estimate MUST always be greater or equal
+ to what _len() returns.
+ _nok(n,k) calculate n over k (binomial coefficient)
+
+The following functions are optional, and can be defined if the underlying lib
+has a fast way to do them. If undefined, Math::BigInt will use pure Perl (hence
+slow) fallback routines to emulate these:
+
+ _signed_or
+ _signed_and
+ _signed_xor
+
+Input strings come in as unsigned but with prefix (i.e. as '123', '0xabc'
+or '0b1101').
+
+So the library needs only to deal with unsigned big integers. Testing of input
+parameter validity is done by the caller, so you need not worry about
+underflow (f.i. in C<_sub()>, C<_dec()>) nor about division by zero or similar
+cases.
+
+The first parameter can be modified, that includes the possibility that you
+return a reference to a completely different object instead. Although keeping
+the reference and just changing its contents is preferred over creating and
+returning a different reference.
+
+Return values are always references to objects, strings, or true/false for
+comparison routines.
+
+=head1 WRAP YOUR OWN
+
+If you want to port your own favourite c-lib for big numbers to the
+Math::BigInt interface, you can take any of the already existing modules as
+a rough guideline. You should really wrap up the latest BigInt and BigFloat
+testsuites with your module, and replace in them any of the following:
+
+ use Math::BigInt;
+
+by this:
+
+ use Math::BigInt lib => 'yourlib';
+
+This way you ensure that your library really works 100% within Math::BigInt.
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
+in late 2000.
+Seperated from BigInt and shaped API with the help of John Peacock.
+
+Fixed, speed-up, streamlined and enhanced by Tels 2001 - 2007.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>,
+L<Math::BigInt::GMP>, L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm b/Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm
new file mode 100644
index 00000000000..5810f5db9f7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm
@@ -0,0 +1,329 @@
+package Math::BigInt::CalcEmu;
+
+use 5.006002;
+use strict;
+# use warnings; # dont use warnings for older Perls
+use vars qw/$VERSION/;
+
+$VERSION = '0.05';
+
+package Math::BigInt;
+
+# See SYNOPSIS below.
+
+my $CALC_EMU;
+
+BEGIN
+ {
+ $CALC_EMU = Math::BigInt->config()->{'lib'};
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( __PACKAGE__, sub { $CALC_EMU = $_[0]; } );
+ }
+
+sub __emu_band
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->bzero(@r) if $y->is_zero() || $x->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if $sx == -1 && $sy == -1;
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx
+ $bx .= $xx x abs($diff);
+ }
+
+ # and the strings together
+ my $r = $bx & $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # One of $x or $y was negative, so need to flip bits in the result.
+ # In both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sign == 1 && !$x->is_zero();
+
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+sub __emu_bior
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->round(@r) if $y->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if ($sx == -1) || ($sy == -1);
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ $bx .= $xx x abs($diff);
+ }
+
+ # or the strings together
+ my $r = $bx | $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # one of $x or $y was negative, so need to flip bits in the result
+ # in both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sign == 1 && !$x->is_zero();
+
+ # if one of X or Y was negative, we need to decrement result
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+sub __emu_bxor
+ {
+ my ($self,$x,$y,$sx,$sy,@r) = @_;
+
+ return $x->round(@r) if $y->is_zero();
+
+ my $sign = 0; # sign of result
+ $sign = 1 if $x->{sign} ne $y->{sign};
+
+ my ($bx,$by);
+
+ if ($sx == -1) # if x is negative
+ {
+ # two's complement: inc and flip all "bits" in $bx
+ $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $bx =~ s/-?0x//;
+ $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $bx = $x->as_hex(); # get binary representation
+ $bx =~ s/-?0x//;
+ $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ if ($sy == -1) # if y is negative
+ {
+ # two's complement: inc and flip all "bits" in $by
+ $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc
+ $by =~ s/-?0x//;
+ $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ else
+ {
+ $by = $y->as_hex(); # get binary representation
+ $by =~ s/-?0x//;
+ $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/;
+ }
+ # now we have bit-strings from X and Y, reverse them for padding
+ $bx = reverse $bx;
+ $by = reverse $by;
+
+ # padd the shorter string
+ my $xx = "\x00"; $xx = "\x0f" if $sx == -1;
+ my $yy = "\x00"; $yy = "\x0f" if $sy == -1;
+ my $diff = CORE::length($bx) - CORE::length($by);
+ if ($diff > 0)
+ {
+ $by .= $yy x $diff;
+ }
+ elsif ($diff < 0)
+ {
+ $bx .= $xx x abs($diff);
+ }
+
+ # xor the strings together
+ my $r = $bx ^ $by;
+
+ # and reverse the result again
+ $bx = reverse $r;
+
+ # one of $x or $y was negative, so need to flip bits in the result
+ # in both cases (one or two of them negative, or both positive) we need
+ # to get the characters back.
+ if ($sign == 1)
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/;
+ }
+ else
+ {
+ $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/;
+ }
+
+ # leading zeros will be stripped by _from_hex()
+ $bx = '0x' . $bx;
+ $x->{value} = $CALC_EMU->_from_hex( $bx );
+
+ # calculate sign of result
+ $x->{sign} = '+';
+ $x->{sign} = '-' if $sx != $sy && !$x->is_zero();
+
+ $x->bdec() if $sign == 1;
+
+ $x->round(@r);
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigInt::CalcEmu - Emulate low-level math with BigInt code
+
+=head1 SYNOPSIS
+
+ use Math::BigInt::CalcEmu;
+
+=head1 DESCRIPTION
+
+Contains routines that emulate low-level math functions in BigInt, e.g.
+optional routines the low-level math package does not provide on its own.
+
+Will be loaded on demand and called automatically by BigInt.
+
+Stuff here is really low-priority to optimize, since it is far better to
+implement the operation in the low-level math libary directly, possible even
+using a call to the native lib.
+
+=head1 METHODS
+
+=head2 __emu_bxor
+
+=head2 __emu_band
+
+=head2 __emu_bior
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+(c) Tels http://bloodgate.com 2003, 2004 - based on BigInt code by
+Tels from 2001-2003.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>, L<Math::BigInt::BitVect>,
+L<Math::BigInt::GMP> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm b/Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm
new file mode 100644
index 00000000000..2b4aea58dc2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm
@@ -0,0 +1,125 @@
+package Math::BigInt::FastCalc;
+
+use 5.006;
+use strict;
+# use warnings; # dont use warnings for older Perls
+
+use DynaLoader;
+use Math::BigInt::Calc;
+
+use vars qw/@ISA $VERSION $BASE $BASE_LEN/;
+
+@ISA = qw(DynaLoader);
+
+$VERSION = '0.19';
+
+bootstrap Math::BigInt::FastCalc $VERSION;
+
+##############################################################################
+# global constants, flags and accessory
+
+# announce that we are compatible with MBI v1.70 and up
+sub api_version () { 1; }
+
+BEGIN
+ {
+ # use Calc to override the methods that we do not provide in XS
+
+ for my $method (qw/
+ str
+ add sub mul div
+ rsft lsft
+ mod modpow modinv
+ gcd
+ pow root sqrt log_int fac nok
+ digit check
+ from_hex from_bin from_oct as_hex as_bin as_oct
+ zeros base_len
+ xor or and
+ alen 1ex
+ /)
+ {
+ no strict 'refs';
+ *{'Math::BigInt::FastCalc::_' . $method} = \&{'Math::BigInt::Calc::_' . $method};
+ }
+ my ($AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL);
+
+ # store BASE_LEN and BASE to later pass it to XS code
+ ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL, $BASE) =
+ Math::BigInt::Calc::_base_len();
+
+ }
+
+sub import
+ {
+ _set_XS_BASE($BASE, $BASE_LEN);
+ }
+
+##############################################################################
+##############################################################################
+
+1;
+__END__
+=pod
+
+=head1 NAME
+
+Math::BigInt::FastCalc - Math::BigInt::Calc with some XS for more speed
+
+=head1 SYNOPSIS
+
+Provides support for big integer calculations. Not intended to be used by
+other modules. Other modules which sport the same functions can also be used
+to support Math::BigInt, like L<Math::BigInt::GMP> or L<Math::BigInt::Pari>.
+
+=head1 DESCRIPTION
+
+In order to allow for multiple big integer libraries, Math::BigInt was
+rewritten to use library modules for core math routines. Any module which
+follows the same API as this can be used instead by using the following:
+
+ use Math::BigInt lib => 'libname';
+
+'libname' is either the long name ('Math::BigInt::Pari'), or only the short
+version like 'Pari'. To use this library:
+
+ use Math::BigInt lib => 'FastCalc';
+
+Note that from L<Math::BigInt> v1.76 onwards, FastCalc will be loaded
+automatically, if possible.
+
+=head1 STORAGE
+
+FastCalc works exactly like Calc, in stores the numbers in decimal form,
+chopped into parts.
+
+=head1 METHODS
+
+The following functions are now implemented in FastCalc.xs:
+
+ _is_odd _is_even _is_one _is_zero
+ _is_two _is_ten
+ _zero _one _two _ten
+ _acmp _len _num
+ _inc _dec
+ __strip_zeros _copy
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
+in late 2000.
+Seperated from BigInt and shaped API with the help of John Peacock.
+Fixed, sped-up and enhanced by Tels http://bloodgate.com 2001-2003.
+Further streamlining (api_version 1 etc.) by Tels 2004-2007.
+
+=head1 SEE ALSO
+
+L<Math::BigInt>, L<Math::BigFloat>,
+L<Math::BigInt::GMP>, L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm b/Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm
new file mode 100644
index 00000000000..4733d226343
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+
+package Math::BigInt::Trace;
+
+require 5.005_02;
+use strict;
+
+use Exporter;
+use Math::BigInt;
+use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
+ $accuracy $precision $round_mode $div_scale);
+
+@ISA = qw(Exporter Math::BigInt);
+
+$VERSION = 0.01;
+
+use overload; # inherit overload from BigInt
+
+# Globals
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $value = shift;
+ my $a = $accuracy; $a = $_[0] if defined $_[0];
+ my $p = $precision; $p = $_[1] if defined $_[1];
+ my $self = Math::BigInt->new($value,$a,$p,$round_mode);
+ bless $self,$class;
+ print "MBI new '$value' => '$self' (",ref($self),")";
+ return $self;
+}
+
+sub import
+ {
+ print "MBI import ",join(' ',@_);
+ my $self = shift;
+ Math::BigInt::import($self,@_); # need it for subclasses
+# $self->export_to_level(1,$self,@_); # need this ?
+ @_ = ();
+ }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Math/BigRat.pm b/Master/tlpkg/tlperl/lib/Math/BigRat.pm
new file mode 100644
index 00000000000..2460d1c7d4e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/BigRat.pm
@@ -0,0 +1,2020 @@
+
+#
+# "Tax the rat farms." - Lord Vetinari
+#
+
+# The following hash values are used:
+# sign : +,-,NaN,+inf,-inf
+# _d : denominator
+# _n : numeraotr (value = _n/_d)
+# _a : accuracy
+# _p : precision
+# You should not look at the innards of a BigRat - use the methods for this.
+
+package Math::BigRat;
+
+# anythig older is untested, and unlikely to work
+use 5.006;
+use strict;
+
+use Math::BigFloat;
+use vars qw($VERSION @ISA $upgrade $downgrade
+ $accuracy $precision $round_mode $div_scale $_trap_nan $_trap_inf);
+
+@ISA = qw(Math::BigFloat);
+
+$VERSION = '0.24';
+$VERSION = eval $VERSION;
+
+use overload; # inherit overload from Math::BigFloat
+
+BEGIN
+ {
+ *objectify = \&Math::BigInt::objectify; # inherit this from BigInt
+ *AUTOLOAD = \&Math::BigFloat::AUTOLOAD; # can't inherit AUTOLOAD
+ # we inherit these from BigFloat because currently it is not possible
+ # that MBF has a different $MBI variable than we, because MBF also uses
+ # Math::BigInt::config->('lib'); (there is always only one library loaded)
+ *_e_add = \&Math::BigFloat::_e_add;
+ *_e_sub = \&Math::BigFloat::_e_sub;
+ *as_int = \&as_number;
+ *is_pos = \&is_positive;
+ *is_neg = \&is_negative;
+ }
+
+##############################################################################
+# Global constants and flags. Access these only via the accessor methods!
+
+$accuracy = $precision = undef;
+$round_mode = 'even';
+$div_scale = 40;
+$upgrade = undef;
+$downgrade = undef;
+
+# These are internally, and not to be used from the outside at all!
+
+$_trap_nan = 0; # are NaNs ok? set w/ config()
+$_trap_inf = 0; # are infs ok? set w/ config()
+
+# the package we are using for our private parts, defaults to:
+# Math::BigInt->config()->{lib}
+my $MBI = 'Math::BigInt::Calc';
+
+my $nan = 'NaN';
+my $class = 'Math::BigRat';
+
+sub isa
+ {
+ return 0 if $_[1] =~ /^Math::Big(Int|Float)/; # we aren't
+ UNIVERSAL::isa(@_);
+ }
+
+##############################################################################
+
+sub _new_from_float
+ {
+ # turn a single float input into a rational number (like '0.1')
+ my ($self,$f) = @_;
+
+ return $self->bnan() if $f->is_nan();
+ return $self->binf($f->{sign}) if $f->{sign} =~ /^[+-]inf$/;
+
+ $self->{_n} = $MBI->_copy( $f->{_m} ); # mantissa
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = $f->{sign} || '+';
+ if ($f->{_es} eq '-')
+ {
+ # something like Math::BigRat->new('0.1');
+ # 1 / 1 => 1/10
+ $MBI->_lsft ( $self->{_d}, $f->{_e} ,10);
+ }
+ else
+ {
+ # something like Math::BigRat->new('10');
+ # 1 / 1 => 10/1
+ $MBI->_lsft ( $self->{_n}, $f->{_e} ,10) unless
+ $MBI->_is_zero($f->{_e});
+ }
+ $self;
+ }
+
+sub new
+ {
+ # create a Math::BigRat
+ my $class = shift;
+
+ my ($n,$d) = @_;
+
+ my $self = { }; bless $self,$class;
+
+ # input like (BigInt) or (BigFloat):
+ if ((!defined $d) && (ref $n) && (!$n->isa('Math::BigRat')))
+ {
+ if ($n->isa('Math::BigFloat'))
+ {
+ $self->_new_from_float($n);
+ }
+ if ($n->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_n} = $MBI->_copy($n->{value}); # "mantissa" = N
+ $self->{_d} = $MBI->_one(); # d => 1
+ $self->{sign} = $n->{sign};
+ }
+ if ($n->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{sign} = '+'; $self->{sign} = '-' if $$n < 0;
+ $self->{_n} = $MBI->_new(abs($$n)); # "mantissa" = N
+ $self->{_d} = $MBI->_one(); # d => 1
+ }
+ return $self->bnorm(); # normalize (120/1 => 12/10)
+ }
+
+ # input like (BigInt,BigInt) or (BigLite,BigLite):
+ if (ref($d) && ref($n))
+ {
+ # do N first (for $self->{sign}):
+ if ($n->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_n} = $MBI->_copy($n->{value}); # "mantissa" = N
+ $self->{sign} = $n->{sign};
+ }
+ elsif ($n->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{sign} = '+'; $self->{sign} = '-' if $$n < 0;
+ $self->{_n} = $MBI->_new(abs($$n)); # "mantissa" = $n
+ }
+ else
+ {
+ require Carp;
+ Carp::croak(ref($n) . " is not a recognized object format for Math::BigRat->new");
+ }
+ # now D:
+ if ($d->isa('Math::BigInt'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_d} = $MBI->_copy($d->{value}); # "mantissa" = D
+ # +/+ or -/- => +, +/- or -/+ => -
+ $self->{sign} = $d->{sign} ne $self->{sign} ? '-' : '+';
+ }
+ elsif ($d->isa('Math::BigInt::Lite'))
+ {
+ # TODO: trap NaN, inf
+ $self->{_d} = $MBI->_new(abs($$d)); # "mantissa" = D
+ my $ds = '+'; $ds = '-' if $$d < 0;
+ # +/+ or -/- => +, +/- or -/+ => -
+ $self->{sign} = $ds ne $self->{sign} ? '-' : '+';
+ }
+ else
+ {
+ require Carp;
+ Carp::croak(ref($d) . " is not a recognized object format for Math::BigRat->new");
+ }
+ return $self->bnorm(); # normalize (120/1 => 12/10)
+ }
+ return $n->copy() if ref $n; # already a BigRat
+
+ if (!defined $n)
+ {
+ $self->{_n} = $MBI->_zero(); # undef => 0
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = '+';
+ return $self;
+ }
+
+ # string input with / delimiter
+ if ($n =~ /\s*\/\s*/)
+ {
+ return $class->bnan() if $n =~ /\/.*\//; # 1/2/3 isn't valid
+ return $class->bnan() if $n =~ /\/\s*$/; # 1/ isn't valid
+ ($n,$d) = split (/\//,$n);
+ # try as BigFloats first
+ if (($n =~ /[\.eE]/) || ($d =~ /[\.eE]/))
+ {
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+
+ # one of them looks like a float
+ my $nf = Math::BigFloat->new($n,undef,undef);
+ $self->{sign} = '+';
+ return $self->bnan() if $nf->is_nan();
+
+ $self->{_n} = $MBI->_copy( $nf->{_m} ); # get mantissa
+
+ # now correct $self->{_n} due to $n
+ my $f = Math::BigFloat->new($d,undef,undef);
+ return $self->bnan() if $f->is_nan();
+ $self->{_d} = $MBI->_copy( $f->{_m} );
+
+ # calculate the difference between nE and dE
+ my $diff_e = $nf->exponent()->bsub( $f->exponent);
+ if ($diff_e->is_negative())
+ {
+ # < 0: mul d with it
+ $MBI->_lsft( $self->{_d}, $MBI->_new( $diff_e->babs()), 10);
+ }
+ elsif (!$diff_e->is_zero())
+ {
+ # > 0: mul n with it
+ $MBI->_lsft( $self->{_n}, $MBI->_new( $diff_e), 10);
+ }
+ }
+ else
+ {
+ # both d and n look like (big)ints
+
+ $self->{sign} = '+'; # no sign => '+'
+ $self->{_n} = undef;
+ $self->{_d} = undef;
+ if ($n =~ /^([+-]?)0*([0-9]+)\z/) # first part ok?
+ {
+ $self->{sign} = $1 || '+'; # no sign => '+'
+ $self->{_n} = $MBI->_new($2 || 0);
+ }
+
+ if ($d =~ /^([+-]?)0*([0-9]+)\z/) # second part ok?
+ {
+ $self->{sign} =~ tr/+-/-+/ if ($1 || '') eq '-'; # negate if second part neg.
+ $self->{_d} = $MBI->_new($2 || 0);
+ }
+
+ if (!defined $self->{_n} || !defined $self->{_d})
+ {
+ $d = Math::BigInt->new($d,undef,undef) unless ref $d;
+ $n = Math::BigInt->new($n,undef,undef) unless ref $n;
+
+ if ($n->{sign} =~ /^[+-]$/ && $d->{sign} =~ /^[+-]$/)
+ {
+ # both parts are ok as integers (wierd things like ' 1e0'
+ $self->{_n} = $MBI->_copy($n->{value});
+ $self->{_d} = $MBI->_copy($d->{value});
+ $self->{sign} = $n->{sign};
+ $self->{sign} =~ tr/+-/-+/ if $d->{sign} eq '-'; # -1/-2 => 1/2
+ return $self->bnorm();
+ }
+
+ $self->{sign} = '+'; # a default sign
+ return $self->bnan() if $n->is_nan() || $d->is_nan();
+
+ # handle inf cases:
+ if ($n->is_inf() || $d->is_inf())
+ {
+ if ($n->is_inf())
+ {
+ return $self->bnan() if $d->is_inf(); # both are inf => NaN
+ my $s = '+'; # '+inf/+123' or '-inf/-123'
+ $s = '-' if substr($n->{sign},0,1) ne $d->{sign};
+ # +-inf/123 => +-inf
+ return $self->binf($s);
+ }
+ # 123/inf => 0
+ return $self->bzero();
+ }
+ }
+ }
+
+ return $self->bnorm();
+ }
+
+ # simple string input
+ if (($n =~ /[\.eE]/) && $n !~ /^0x/)
+ {
+ # looks like a float, quacks like a float, so probably is a float
+ $self->{sign} = 'NaN';
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+ $self->_new_from_float(Math::BigFloat->new($n,undef,undef));
+ }
+ else
+ {
+ # for simple forms, use $MBI directly
+ if ($n =~ /^([+-]?)0*([0-9]+)\z/)
+ {
+ $self->{sign} = $1 || '+';
+ $self->{_n} = $MBI->_new($2 || 0);
+ $self->{_d} = $MBI->_one();
+ }
+ else
+ {
+ my $n = Math::BigInt->new($n,undef,undef);
+ $self->{_n} = $MBI->_copy($n->{value});
+ $self->{_d} = $MBI->_one();
+ $self->{sign} = $n->{sign};
+ return $self->bnan() if $self->{sign} eq 'NaN';
+ return $self->binf($self->{sign}) if $self->{sign} =~ /^[+-]inf$/;
+ }
+ }
+ $self->bnorm();
+ }
+
+sub copy
+ {
+ # if two arguments, the first one is the class to "swallow" subclasses
+ my ($c,$x) = @_;
+
+ if (scalar @_ == 1)
+ {
+ $x = $_[0];
+ $c = ref($x);
+ }
+ return unless ref($x); # only for objects
+
+ my $self = bless {}, $c;
+
+ $self->{sign} = $x->{sign};
+ $self->{_d} = $MBI->_copy($x->{_d});
+ $self->{_n} = $MBI->_copy($x->{_n});
+ $self->{_a} = $x->{_a} if defined $x->{_a};
+ $self->{_p} = $x->{_p} if defined $x->{_p};
+ $self;
+ }
+
+##############################################################################
+
+sub config
+ {
+ # return (later set?) configuration data as hash ref
+ my $class = shift || 'Math::BigRat';
+
+ if (@_ == 1 && ref($_[0]) ne 'HASH')
+ {
+ my $cfg = $class->SUPER::config();
+ return $cfg->{$_[0]};
+ }
+
+ my $cfg = $class->SUPER::config(@_);
+
+ # now we need only to override the ones that are different from our parent
+ $cfg->{class} = $class;
+ $cfg->{with} = $MBI;
+ $cfg;
+ }
+
+##############################################################################
+
+sub bstr
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/) # inf, NaN etc
+ {
+ my $s = $x->{sign}; $s =~ s/^\+//; # +inf => inf
+ return $s;
+ }
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} ne '+'; # '+3/2' => '3/2'
+
+ return $s . $MBI->_str($x->{_n}) if $MBI->_is_one($x->{_d});
+ $s . $MBI->_str($x->{_n}) . '/' . $MBI->_str($x->{_d});
+ }
+
+sub bsstr
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ if ($x->{sign} !~ /^[+-]$/) # inf, NaN etc
+ {
+ my $s = $x->{sign}; $s =~ s/^\+//; # +inf => inf
+ return $s;
+ }
+
+ my $s = ''; $s = $x->{sign} if $x->{sign} ne '+'; # +3 vs 3
+ $s . $MBI->_str($x->{_n}) . '/' . $MBI->_str($x->{_d});
+ }
+
+sub bnorm
+ {
+ # reduce the number to the shortest form
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ # Both parts must be objects of whatever we are using today.
+ if ( my $c = $MBI->_check($x->{_n}) )
+ {
+ require Carp; Carp::croak ("n did not pass the self-check ($c) in bnorm()");
+ }
+ if ( my $c = $MBI->_check($x->{_d}) )
+ {
+ require Carp; Carp::croak ("d did not pass the self-check ($c) in bnorm()");
+ }
+
+ # no normalize for NaN, inf etc.
+ return $x if $x->{sign} !~ /^[+-]$/;
+
+ # normalize zeros to 0/1
+ if ($MBI->_is_zero($x->{_n}))
+ {
+ $x->{sign} = '+'; # never leave a -0
+ $x->{_d} = $MBI->_one() unless $MBI->_is_one($x->{_d});
+ return $x;
+ }
+
+ return $x if $MBI->_is_one($x->{_d}); # no need to reduce
+
+ # reduce other numbers
+ my $gcd = $MBI->_copy($x->{_n});
+ $gcd = $MBI->_gcd($gcd,$x->{_d});
+
+ if (!$MBI->_is_one($gcd))
+ {
+ $x->{_n} = $MBI->_div($x->{_n},$gcd);
+ $x->{_d} = $MBI->_div($x->{_d},$gcd);
+ }
+ $x;
+ }
+
+##############################################################################
+# sign manipulation
+
+sub bneg
+ {
+ # (BRAT or num_str) return BRAT
+ # negate number or make a negated number from string
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x if $x->modify('bneg');
+
+ # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
+ $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $MBI->_is_zero($x->{_n}));
+ $x;
+ }
+
+##############################################################################
+# special values
+
+sub _bnan
+ {
+ # used by parent class bnan() to initialize number to NaN
+ my $self = shift;
+
+ if ($_trap_nan)
+ {
+ require Carp;
+ my $class = ref($self);
+ # "$self" below will stringify the object, this blows up if $self is a
+ # partial object (happens under trap_nan), so fix it beforehand
+ $self->{_d} = $MBI->_zero() unless defined $self->{_d};
+ $self->{_n} = $MBI->_zero() unless defined $self->{_n};
+ Carp::croak ("Tried to set $self to NaN in $class\::_bnan()");
+ }
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_zero();
+ }
+
+sub _binf
+ {
+ # used by parent class bone() to initialize number to +inf/-inf
+ my $self = shift;
+
+ if ($_trap_inf)
+ {
+ require Carp;
+ my $class = ref($self);
+ # "$self" below will stringify the object, this blows up if $self is a
+ # partial object (happens under trap_nan), so fix it beforehand
+ $self->{_d} = $MBI->_zero() unless defined $self->{_d};
+ $self->{_n} = $MBI->_zero() unless defined $self->{_n};
+ Carp::croak ("Tried to set $self to inf in $class\::_binf()");
+ }
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_zero();
+ }
+
+sub _bone
+ {
+ # used by parent class bone() to initialize number to +1/-1
+ my $self = shift;
+ $self->{_n} = $MBI->_one();
+ $self->{_d} = $MBI->_one();
+ }
+
+sub _bzero
+ {
+ # used by parent class bzero() to initialize number to 0
+ my $self = shift;
+ $self->{_n} = $MBI->_zero();
+ $self->{_d} = $MBI->_one();
+ }
+
+##############################################################################
+# mul/add/div etc
+
+sub badd
+ {
+ # add two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # +inf + +inf => +inf, -inf + -inf => -inf
+ return $x->binf(substr($x->{sign},0,1))
+ if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+
+ # +inf + -inf or -inf + +inf => NaN
+ return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
+
+ # 1 1 gcd(3,4) = 1 1*3 + 1*4 7
+ # - + - = --------- = --
+ # 4 3 4*3 12
+
+ # we do not compute the gcd() here, but simple do:
+ # 5 7 5*3 + 7*4 43
+ # - + - = --------- = --
+ # 4 3 4*3 12
+
+ # and bnorm() will then take care of the rest
+
+ # 5 * 3
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});
+
+ # 7 * 4
+ my $m = $MBI->_mul( $MBI->_copy( $y->{_n} ), $x->{_d} );
+
+ # 5 * 3 + 7 * 4
+ ($x->{_n}, $x->{sign}) = _e_add( $x->{_n}, $m, $x->{sign}, $y->{sign});
+
+ # 4 * 3
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});
+
+ # normalize result, and possible round
+ $x->bnorm()->round(@r);
+ }
+
+sub bsub
+ {
+ # subtract two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # flip sign of $x, call badd(), then flip sign of result
+ $x->{sign} =~ tr/+-/-+/
+ unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n}); # not -0
+ $x->badd($y,@r); # does norm and round
+ $x->{sign} =~ tr/+-/-+/
+ unless $x->{sign} eq '+' && $MBI->_is_zero($x->{_n}); # not -0
+ $x;
+ }
+
+sub bmul
+ {
+ # multiply two rational numbers
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x->bnan() if ($x->{sign} eq 'NaN' || $y->{sign} eq 'NaN');
+
+ # inf handling
+ if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
+ {
+ return $x->bnan() if $x->is_zero() || $y->is_zero();
+ # result will always be +-inf:
+ # +inf * +/+inf => +inf, -inf * -/-inf => +inf
+ # +inf * -/-inf => -inf, -inf * +/+inf => -inf
+ return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
+ return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
+ return $x->binf('-');
+ }
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # XXX TODO:
+ # According to Knuth, this can be optimized by doing gcd twice (for d and n)
+ # and reducing in one step. This would save us the bnorm() at the end.
+
+ # 1 2 1 * 2 2 1
+ # - * - = ----- = - = -
+ # 4 3 4 * 3 12 6
+
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_n});
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_d});
+
+ # compute new sign
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+
+ $x->bnorm()->round(@r);
+ }
+
+sub bdiv
+ {
+ # (dividend: BRAT or num_str, divisor: BRAT or num_str) return
+ # (BRAT,BRAT) (quo,rem) or BRAT (only rem)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ # x== 0 # also: or y == 1 or y == -1
+ return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
+
+ # XXX TODO: list context, upgrade
+ # According to Knuth, this can be optimized by doing gcd twice (for d and n)
+ # and reducing in one step. This would save us the bnorm() at the end.
+
+ # 1 1 1 3
+ # - / - == - * -
+ # 4 3 4 1
+
+ $x->{_n} = $MBI->_mul( $x->{_n}, $y->{_d});
+ $x->{_d} = $MBI->_mul( $x->{_d}, $y->{_n});
+
+ # compute new sign
+ $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
+
+ $x->bnorm()->round(@r);
+ $x;
+ }
+
+sub bmod
+ {
+ # compute "remainder" (in Perl way) of $x / $y
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $self->_div_inf($x,$y)
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
+
+ return $x if $x->is_zero(); # 0 / 7 = 0, mod 0
+
+ # compute $x - $y * floor($x/$y), keeping the sign of $x
+
+ # copy x to u, make it positive and then do a normal division ($u/$y)
+ my $u = bless { sign => '+' }, $self;
+ $u->{_n} = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d} );
+ $u->{_d} = $MBI->_mul( $MBI->_copy($x->{_d}), $y->{_n} );
+
+ # compute floor(u)
+ if (! $MBI->_is_one($u->{_d}))
+ {
+ $u->{_n} = $MBI->_div($u->{_n},$u->{_d}); # 22/7 => 3/1 w/ truncate
+ # no need to set $u->{_d} to 1, since below we set it to $y->{_d} anyway
+ }
+
+ # now compute $y * $u
+ $u->{_d} = $MBI->_copy($y->{_d}); # 1 * $y->{_d}, see floor above
+ $u->{_n} = $MBI->_mul($u->{_n},$y->{_n});
+
+ my $xsign = $x->{sign}; $x->{sign} = '+'; # remember sign and make x positive
+ # compute $x - $u
+ $x->bsub($u);
+ $x->{sign} = $xsign; # put sign back
+
+ $x->bnorm()->round(@r);
+ }
+
+##############################################################################
+# bdec/binc
+
+sub bdec
+ {
+ # decrement value (subtract 1)
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf
+
+ if ($x->{sign} eq '-')
+ {
+ $x->{_n} = $MBI->_add( $x->{_n}, $x->{_d}); # -5/2 => -7/2
+ }
+ else
+ {
+ if ($MBI->_acmp($x->{_n},$x->{_d}) < 0) # n < d?
+ {
+ # 1/3 -- => -2/3
+ $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
+ $x->{sign} = '-';
+ }
+ else
+ {
+ $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); # 5/2 => 3/2
+ }
+ }
+ $x->bnorm()->round(@r);
+ }
+
+sub binc
+ {
+ # increment value (add 1)
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf
+
+ if ($x->{sign} eq '-')
+ {
+ if ($MBI->_acmp($x->{_n},$x->{_d}) < 0)
+ {
+ # -1/3 ++ => 2/3 (overflow at 0)
+ $x->{_n} = $MBI->_sub( $MBI->_copy($x->{_d}), $x->{_n});
+ $x->{sign} = '+';
+ }
+ else
+ {
+ $x->{_n} = $MBI->_sub($x->{_n}, $x->{_d}); # -5/2 => -3/2
+ }
+ }
+ else
+ {
+ $x->{_n} = $MBI->_add($x->{_n},$x->{_d}); # 5/2 => 7/2
+ }
+ $x->bnorm()->round(@r);
+ }
+
+##############################################################################
+# is_foo methods (the rest is inherited)
+
+sub is_int
+ {
+ # return true if arg (BRAT or num_str) is an integer
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't
+ $MBI->_is_one($x->{_d}); # x/y && y != 1 => no integer
+ 0;
+ }
+
+sub is_zero
+ {
+ # return true if arg (BRAT or num_str) is zero
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if $x->{sign} eq '+' && $MBI->_is_zero($x->{_n});
+ 0;
+ }
+
+sub is_one
+ {
+ # return true if arg (BRAT or num_str) is +1 or -1 if signis given
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ my $sign = $_[2] || ''; $sign = '+' if $sign ne '-';
+ return 1
+ if ($x->{sign} eq $sign && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}));
+ 0;
+ }
+
+sub is_odd
+ {
+ # return true if arg (BFLOAT or num_str) is odd or false if even
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
+ ($MBI->_is_one($x->{_d}) && $MBI->_is_odd($x->{_n})); # x/2 is not, but 3/1
+ 0;
+ }
+
+sub is_even
+ {
+ # return true if arg (BINT or num_str) is even or false if odd
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
+ return 1 if ($MBI->_is_one($x->{_d}) # x/3 is never
+ && $MBI->_is_even($x->{_n})); # but 4/1 is
+ 0;
+ }
+
+##############################################################################
+# parts() and friends
+
+sub numerator
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ # NaN, inf, -inf
+ return Math::BigInt->new($x->{sign}) if ($x->{sign} !~ /^[+-]$/);
+
+ my $n = Math::BigInt->new($MBI->_str($x->{_n})); $n->{sign} = $x->{sign};
+ $n;
+ }
+
+sub denominator
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ # NaN
+ return Math::BigInt->new($x->{sign}) if $x->{sign} eq 'NaN';
+ # inf, -inf
+ return Math::BigInt->bone() if $x->{sign} !~ /^[+-]$/;
+
+ Math::BigInt->new($MBI->_str($x->{_d}));
+ }
+
+sub parts
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ my $c = 'Math::BigInt';
+
+ return ($c->bnan(),$c->bnan()) if $x->{sign} eq 'NaN';
+ return ($c->binf(),$c->binf()) if $x->{sign} eq '+inf';
+ return ($c->binf('-'),$c->binf()) if $x->{sign} eq '-inf';
+
+ my $n = $c->new( $MBI->_str($x->{_n}));
+ $n->{sign} = $x->{sign};
+ my $d = $c->new( $MBI->_str($x->{_d}));
+ ($n,$d);
+ }
+
+sub length
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $nan unless $x->is_int();
+ $MBI->_len($x->{_n}); # length(-123/1) => length(123)
+ }
+
+sub digit
+ {
+ my ($self,$x,$n) = ref($_[0]) ? (undef,$_[0],$_[1]) : objectify(1,@_);
+
+ return $nan unless $x->is_int();
+ $MBI->_digit($x->{_n},$n || 0); # digit(-123/1,2) => digit(123,2)
+ }
+
+##############################################################################
+# special calc routines
+
+sub bceil
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/ || # not for NaN, inf
+ $MBI->_is_one($x->{_d}); # 22/1 => 22, 0/1 => 0
+
+ $x->{_n} = $MBI->_div($x->{_n},$x->{_d}); # 22/7 => 3/1 w/ truncate
+ $x->{_d} = $MBI->_one(); # d => 1
+ $x->{_n} = $MBI->_inc($x->{_n})
+ if $x->{sign} eq '+'; # +22/7 => 4/1
+ $x->{sign} = '+' if $MBI->_is_zero($x->{_n}); # -0 => 0
+ $x;
+ }
+
+sub bfloor
+ {
+ my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
+
+ return $x if $x->{sign} !~ /^[+-]$/ || # not for NaN, inf
+ $MBI->_is_one($x->{_d}); # 22/1 => 22, 0/1 => 0
+
+ $x->{_n} = $MBI->_div($x->{_n},$x->{_d}); # 22/7 => 3/1 w/ truncate
+ $x->{_d} = $MBI->_one(); # d => 1
+ $x->{_n} = $MBI->_inc($x->{_n})
+ if $x->{sign} eq '-'; # -22/7 => -4/1
+ $x;
+ }
+
+sub bfac
+ {
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ # if $x is not an integer
+ if (($x->{sign} ne '+') || (!$MBI->_is_one($x->{_d})))
+ {
+ return $x->bnan();
+ }
+
+ $x->{_n} = $MBI->_fac($x->{_n});
+ # since _d is 1, we don't need to reduce/norm the result
+ $x->round(@r);
+ }
+
+sub bpow
+ {
+ # power ($x ** $y)
+
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ return $x if $x->{sign} =~ /^[+-]inf$/; # -inf/+inf ** x
+ return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
+ return $x->bone(@r) if $y->is_zero();
+ return $x->round(@r) if $x->is_one() || $y->is_one();
+
+ if ($x->{sign} eq '-' && $MBI->_is_one($x->{_n}) && $MBI->_is_one($x->{_d}))
+ {
+ # if $x == -1 and odd/even y => +1/-1
+ return $y->is_odd() ? $x->round(@r) : $x->babs()->round(@r);
+ # my Casio FX-5500L has a bug here: -1 ** 2 is -1, but -1 * -1 is 1;
+ }
+ # 1 ** -y => 1 / (1 ** |y|)
+ # so do test for negative $y after above's clause
+
+ return $x->round(@r) if $x->is_zero(); # 0**y => 0 (if not y <= 0)
+
+ # shortcut if y == 1/N (is then sqrt() respective broot())
+ if ($MBI->_is_one($y->{_n}))
+ {
+ return $x->bsqrt(@r) if $MBI->_is_two($y->{_d}); # 1/2 => sqrt
+ return $x->broot($MBI->_str($y->{_d}),@r); # 1/N => root(N)
+ }
+
+ # shortcut y/1 (and/or x/1)
+ if ($MBI->_is_one($y->{_d}))
+ {
+ # shortcut for x/1 and y/1
+ if ($MBI->_is_one($x->{_d}))
+ {
+ $x->{_n} = $MBI->_pow($x->{_n},$y->{_n}); # x/1 ** y/1 => (x ** y)/1
+ if ($y->{sign} eq '-')
+ {
+ # 0.2 ** -3 => 1/(0.2 ** 3)
+ ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n}); # swap
+ }
+ # correct sign; + ** + => +
+ if ($x->{sign} eq '-')
+ {
+ # - * - => +, - * - * - => -
+ $x->{sign} = '+' if $MBI->_is_even($y->{_n});
+ }
+ return $x->round(@r);
+ }
+ # x/z ** y/1
+ $x->{_n} = $MBI->_pow($x->{_n},$y->{_n}); # 5/2 ** y/1 => 5 ** y / 2 ** y
+ $x->{_d} = $MBI->_pow($x->{_d},$y->{_n});
+ if ($y->{sign} eq '-')
+ {
+ # 0.2 ** -3 => 1/(0.2 ** 3)
+ ($x->{_n},$x->{_d}) = ($x->{_d},$x->{_n}); # swap
+ }
+ # correct sign; + ** + => +
+ if ($x->{sign} eq '-')
+ {
+ # - * - => +, - * - * - => -
+ $x->{sign} = '+' if $MBI->_is_even($y->{_n});
+ }
+ return $x->round(@r);
+ }
+
+# print STDERR "# $x $y\n";
+
+ # otherwise:
+
+ # n/d n ______________
+ # a/b = -\/ (a/b) ** d
+
+ # (a/b) ** n == (a ** n) / (b ** n)
+ $MBI->_pow($x->{_n}, $y->{_n} );
+ $MBI->_pow($x->{_d}, $y->{_n} );
+
+ return $x->broot($MBI->_str($y->{_d}),@r); # n/d => root(n)
+ }
+
+sub blog
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ # blog(1,Y) => 0
+ return $x->bzero() if $x->is_one() && $y->{sign} eq '+';
+
+ # $x <= 0 => NaN
+ return $x->bnan() if $x->is_zero() || $x->{sign} ne '+' || $y->{sign} ne '+';
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->blog($y->as_number(),@r));
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->blog(Math::BigFloat->new("$y"),@r) );
+ }
+
+sub bexp
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ return $x->binf(@r) if $x->{sign} eq '+inf';
+ return $x->bzero(@r) if $x->{sign} eq '-inf';
+
+ # we need to limit the accuracy to protect against overflow
+ my $fallback = 0;
+ my ($scale,@params);
+ ($x,@params) = $x->_find_round_parameters(@r);
+
+ # also takes care of the "error in _find_round_parameters?" case
+ return $x if $x->{sign} eq 'NaN';
+
+ # no rounding at all, so must use fallback
+ if (scalar @params == 0)
+ {
+ # simulate old behaviour
+ $params[0] = $self->div_scale(); # and round to it as accuracy
+ $params[1] = undef; # P = undef
+ $scale = $params[0]+4; # at least four more for proper round
+ $params[2] = $r[2]; # round mode by caller or undef
+ $fallback = 1; # to clear a/p afterwards
+ }
+ else
+ {
+ # the 4 below is empirical, and there might be cases where it's not enough...
+ $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
+ }
+
+ return $x->bone(@params) if $x->is_zero();
+
+ # See the comments in Math::BigFloat on how this algorithm works.
+ # Basically we calculate A and B (where B is faculty(N)) so that A/B = e
+
+ my $x_org = $x->copy();
+ if ($scale <= 75)
+ {
+ # set $x directly from a cached string form
+ $x->{_n} = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ $x->{_d} = $MBI->_new("33452526613163807108170062053440751665152000000000");
+ $x->{sign} = '+';
+ }
+ else
+ {
+ # compute A and B so that e = A / B.
+
+ # After some terms we end up with this, so we use it as a starting point:
+ my $A = $MBI->_new("90933395208605785401971970164779391644753259799242");
+ my $F = $MBI->_new(42); my $step = 42;
+
+ # Compute how many steps we need to take to get $A and $B sufficiently big
+ my $steps = Math::BigFloat::_len_to_steps($scale - 4);
+# print STDERR "# Doing $steps steps for ", $scale-4, " digits\n";
+ while ($step++ <= $steps)
+ {
+ # calculate $a * $f + 1
+ $A = $MBI->_mul($A, $F);
+ $A = $MBI->_inc($A);
+ # increment f
+ $F = $MBI->_inc($F);
+ }
+ # compute $B as factorial of $steps (this is faster than doing it manually)
+ my $B = $MBI->_fac($MBI->_new($steps));
+
+# print "A ", $MBI->_str($A), "\nB ", $MBI->_str($B), "\n";
+
+ $x->{_n} = $A;
+ $x->{_d} = $B;
+ $x->{sign} = '+';
+ }
+
+ # $x contains now an estimate of e, with some surplus digits, so we can round
+ if (!$x_org->is_one())
+ {
+ # raise $x to the wanted power and round it in one step:
+ $x->bpow($x_org, @params);
+ }
+ else
+ {
+ # else just round the already computed result
+ delete $x->{_a}; delete $x->{_p};
+ # shortcut to not run through _find_round_parameters again
+ if (defined $params[0])
+ {
+ $x->bround($params[0],$params[2]); # then round accordingly
+ }
+ else
+ {
+ $x->bfround($params[1],$params[2]); # then round accordingly
+ }
+ }
+ if ($fallback)
+ {
+ # clear a/p after round, since user did not request it
+ delete $x->{_a}; delete $x->{_p};
+ }
+
+ $x;
+ }
+
+sub bnok
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,$class,@_);
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->bnok(Math::BigFloat->new("$y"),@r) );
+ }
+
+sub _float_from_part
+ {
+ my $x = shift;
+
+ my $f = Math::BigFloat->bzero();
+ $f->{_m} = $MBI->_copy($x);
+ $f->{_e} = $MBI->_zero();
+
+ $f;
+ }
+
+sub _as_float
+ {
+ my $x = shift;
+
+ local $Math::BigFloat::upgrade = undef;
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigFloat::precision = undef;
+ # 22/7 => 3.142857143..
+
+ my $a = $x->accuracy() || 0;
+ if ($a != 0 || !$MBI->_is_one($x->{_d}))
+ {
+ # n/d
+ return scalar Math::BigFloat->new($x->{sign} . $MBI->_str($x->{_n}))->bdiv( $MBI->_str($x->{_d}), $x->accuracy());
+ }
+ # just n
+ Math::BigFloat->new($x->{sign} . $MBI->_str($x->{_n}));
+ }
+
+sub broot
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->broot($y->as_number(),@r));
+ }
+
+ # do it with floats
+ $x->_new_from_float( $x->_as_float()->broot($y->_as_float(),@r) )->bnorm()->bround(@r);
+ }
+
+sub bmodpow
+ {
+ # set up parameters
+ my ($self,$x,$y,$m,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,$m,@r) = objectify(3,@_);
+ }
+
+ # $x or $y or $m are NaN or +-inf => NaN
+ return $x->bnan()
+ if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/ ||
+ $m->{sign} !~ /^[+-]$/;
+
+ if ($x->is_int() && $y->is_int() && $m->is_int())
+ {
+ return $self->new($x->as_number()->bmodpow($y->as_number(),$m,@r));
+ }
+
+ warn ("bmodpow() not fully implemented");
+ $x->bnan();
+ }
+
+sub bmodinv
+ {
+ # set up parameters
+ my ($self,$x,$y,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y,@r) = objectify(2,@_);
+ }
+
+ # $x or $y are NaN or +-inf => NaN
+ return $x->bnan()
+ if $x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/;
+
+ if ($x->is_int() && $y->is_int())
+ {
+ return $self->new($x->as_number()->bmodinv($y->as_number(),@r));
+ }
+
+ warn ("bmodinv() not fully implemented");
+ $x->bnan();
+ }
+
+sub bsqrt
+ {
+ my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
+
+ return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0
+ return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf
+ return $x->round(@r) if $x->is_zero() || $x->is_one();
+
+ local $Math::BigFloat::upgrade = undef;
+ local $Math::BigFloat::downgrade = undef;
+ local $Math::BigFloat::precision = undef;
+ local $Math::BigFloat::accuracy = undef;
+ local $Math::BigInt::upgrade = undef;
+ local $Math::BigInt::precision = undef;
+ local $Math::BigInt::accuracy = undef;
+
+ $x->{_n} = _float_from_part( $x->{_n} )->bsqrt();
+ $x->{_d} = _float_from_part( $x->{_d} )->bsqrt();
+
+ # XXX TODO: we probably can optimze this:
+
+ # if sqrt(D) was not integer
+ if ($x->{_d}->{_es} ne '+')
+ {
+ $x->{_n}->blsft($x->{_d}->exponent()->babs(),10); # 7.1/4.51 => 7.1/45.1
+ $x->{_d} = $MBI->_copy( $x->{_d}->{_m} ); # 7.1/45.1 => 71/45.1
+ }
+ # if sqrt(N) was not integer
+ if ($x->{_n}->{_es} ne '+')
+ {
+ $x->{_d}->blsft($x->{_n}->exponent()->babs(),10); # 71/45.1 => 710/45.1
+ $x->{_n} = $MBI->_copy( $x->{_n}->{_m} ); # 710/45.1 => 710/451
+ }
+
+ # convert parts to $MBI again
+ $x->{_n} = $MBI->_lsft( $MBI->_copy( $x->{_n}->{_m} ), $x->{_n}->{_e}, 10)
+ if ref($x->{_n}) ne $MBI && ref($x->{_n}) ne 'ARRAY';
+ $x->{_d} = $MBI->_lsft( $MBI->_copy( $x->{_d}->{_m} ), $x->{_d}->{_e}, 10)
+ if ref($x->{_d}) ne $MBI && ref($x->{_d}) ne 'ARRAY';
+
+ $x->bnorm()->round(@r);
+ }
+
+sub blsft
+ {
+ my ($self,$x,$y,$b,@r) = objectify(3,@_);
+
+ $b = 2 unless defined $b;
+ $b = $self->new($b) unless ref ($b);
+ $x->bmul( $b->copy()->bpow($y), @r);
+ $x;
+ }
+
+sub brsft
+ {
+ my ($self,$x,$y,$b,@r) = objectify(3,@_);
+
+ $b = 2 unless defined $b;
+ $b = $self->new($b) unless ref ($b);
+ $x->bdiv( $b->copy()->bpow($y), @r);
+ $x;
+ }
+
+##############################################################################
+# round
+
+sub round
+ {
+ $_[0];
+ }
+
+sub bround
+ {
+ $_[0];
+ }
+
+sub bfround
+ {
+ $_[0];
+ }
+
+##############################################################################
+# comparing
+
+sub bcmp
+ {
+ # compare two signed numbers
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,@_);
+ }
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1;
+ }
+ # check sign for speed first
+ return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
+ return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
+
+ # shortcut
+ my $xz = $MBI->_is_zero($x->{_n});
+ my $yz = $MBI->_is_zero($y->{_n});
+ return 0 if $xz && $yz; # 0 <=> 0
+ return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y
+ return 1 if $yz && $x->{sign} eq '+'; # +x <=> 0
+
+ my $t = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d});
+ my $u = $MBI->_mul( $MBI->_copy($y->{_n}), $x->{_d});
+
+ my $cmp = $MBI->_acmp($t,$u); # signs are equal
+ $cmp = -$cmp if $x->{sign} eq '-'; # both are '-' => reverse
+ $cmp;
+ }
+
+sub bacmp
+ {
+ # compare two numbers (as unsigned)
+
+ # set up parameters
+ my ($self,$x,$y) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
+ {
+ ($self,$x,$y) = objectify(2,$class,@_);
+ }
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
+ return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
+ return -1;
+ }
+
+ my $t = $MBI->_mul( $MBI->_copy($x->{_n}), $y->{_d});
+ my $u = $MBI->_mul( $MBI->_copy($y->{_n}), $x->{_d});
+ $MBI->_acmp($t,$u); # ignore signs
+ }
+
+##############################################################################
+# output conversation
+
+sub numify
+ {
+ # convert 17/8 => float (aka 2.125)
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, NaN, etc
+
+ # N/1 => N
+ my $neg = ''; $neg = '-' if $x->{sign} eq '-';
+ return $neg . $MBI->_num($x->{_n}) if $MBI->_is_one($x->{_d});
+
+ $x->_as_float()->numify() + 0.0;
+ }
+
+sub as_number
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ # NaN, inf etc
+ return Math::BigInt->new($x->{sign}) if $x->{sign} !~ /^[+-]$/;
+
+ my $u = Math::BigInt->bzero();
+ $u->{sign} = $x->{sign};
+ $u->{value} = $MBI->_div( $MBI->_copy($x->{_n}), $x->{_d}); # 22/7 => 3
+ $u;
+ }
+
+sub as_float
+ {
+ # return N/D as Math::BigFloat
+
+ # set up parameters
+ my ($self,$x,@r) = (ref($_[0]),@_);
+ # objectify is costly, so avoid it
+ ($self,$x,@r) = objectify(1,$class,@_) unless ref $_[0];
+
+ # NaN, inf etc
+ return Math::BigFloat->new($x->{sign}) if $x->{sign} !~ /^[+-]$/;
+
+ my $u = Math::BigFloat->bzero();
+ $u->{sign} = $x->{sign};
+ # n
+ $u->{_m} = $MBI->_copy($x->{_n});
+ $u->{_e} = $MBI->_zero();
+ $u->bdiv( $MBI->_str($x->{_d}), @r);
+ # return $u
+ $u;
+ }
+
+sub as_bin
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_bin($x->{_n});
+ }
+
+sub as_hex
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_hex($x->{_n});
+ }
+
+sub as_oct
+ {
+ my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
+
+ return $x unless $x->is_int();
+
+ my $s = $x->{sign}; $s = '' if $s eq '+';
+ $s . $MBI->_as_oct($x->{_n});
+ }
+
+##############################################################################
+
+sub from_hex
+ {
+ my $class = shift;
+
+ $class->new(@_);
+ }
+
+sub from_bin
+ {
+ my $class = shift;
+
+ $class->new(@_);
+ }
+
+sub from_oct
+ {
+ my $class = shift;
+
+ my @parts;
+ for my $c (@_)
+ {
+ push @parts, Math::BigInt->from_oct($c);
+ }
+ $class->new ( @parts );
+ }
+
+##############################################################################
+# import
+
+sub import
+ {
+ my $self = shift;
+ my $l = scalar @_;
+ my $lib = ''; my @a;
+ my $try = 'try';
+
+ for ( my $i = 0; $i < $l ; $i++)
+ {
+ if ( $_[$i] eq ':constant' )
+ {
+ # this rest causes overlord er load to step in
+ overload::constant float => sub { $self->new(shift); };
+ }
+# elsif ($_[$i] eq 'upgrade')
+# {
+# # this causes upgrading
+# $upgrade = $_[$i+1]; # or undef to disable
+# $i++;
+# }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ $i++;
+ }
+ elsif ($_[$i] =~ /^(lib|try|only)\z/)
+ {
+ $lib = $_[$i+1] || ''; # default Calc
+ $try = $1; # lib, try or only
+ $i++;
+ }
+ elsif ($_[$i] eq 'with')
+ {
+ # this argument is no longer used
+ #$MBI = $_[$i+1] || 'Math::BigInt::Calc'; # default Math::BigInt::Calc
+ $i++;
+ }
+ else
+ {
+ push @a, $_[$i];
+ }
+ }
+ require Math::BigInt;
+
+ # let use Math::BigInt lib => 'GMP'; use Math::BigRat; still have GMP
+ if ($lib ne '')
+ {
+ my @c = split /\s*,\s*/, $lib;
+ foreach (@c)
+ {
+ $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
+ }
+ $lib = join(",", @c);
+ }
+ my @import = ('objectify');
+ push @import, $try => $lib if $lib ne '';
+
+ # MBI already loaded, so feed it our lib arguments
+ Math::BigInt->import( @import );
+
+ $MBI = Math::BigFloat->config()->{lib};
+
+ # register us with MBI to get notified of future lib changes
+ Math::BigInt::_register_callback( $self, sub { $MBI = $_[0]; } );
+
+ # any non :constant stuff is handled by our parent, Exporter (loaded
+ # by Math::BigFloat, even if @_ is empty, to give it a chance
+ $self->SUPER::import(@a); # for subclasses
+ $self->export_to_level(1,$self,@a); # need this, too
+ }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Math::BigRat - Arbitrary big rational numbers
+
+=head1 SYNOPSIS
+
+ use Math::BigRat;
+
+ my $x = Math::BigRat->new('3/7'); $x += '5/9';
+
+ print $x->bstr(),"\n";
+ print $x ** 2,"\n";
+
+ my $y = Math::BigRat->new('inf');
+ print "$y ", ($y->is_inf ? 'is' : 'is not') , " infinity\n";
+
+ my $z = Math::BigRat->new(144); $z->bsqrt();
+
+=head1 DESCRIPTION
+
+Math::BigRat complements Math::BigInt and Math::BigFloat by providing support
+for arbitrary big rational numbers.
+
+=head2 MATH LIBRARY
+
+You can change the underlying module that does the low-level
+math operations by using:
+
+ use Math::BigRat try => 'GMP';
+
+Note: This needs Math::BigInt::GMP installed.
+
+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 Math::BigRat try => 'Foo,Math::BigInt::Bar';
+
+If you want to get warned when the fallback occurs, replace "try" with
+"lib":
+
+ use Math::BigRat lib => 'Foo,Math::BigInt::Bar';
+
+If you want the code to die instead, replace "try" with
+"only":
+
+ use Math::BigRat only => 'Foo,Math::BigInt::Bar';
+
+=head1 METHODS
+
+Any methods not listed here are derived from Math::BigFloat (or
+Math::BigInt), so make sure you check these two modules for further
+information.
+
+=head2 new()
+
+ $x = Math::BigRat->new('1/3');
+
+Create a new Math::BigRat object. Input can come in various forms:
+
+ $x = Math::BigRat->new(123); # scalars
+ $x = Math::BigRat->new('inf'); # infinity
+ $x = Math::BigRat->new('123.3'); # float
+ $x = Math::BigRat->new('1/3'); # simple string
+ $x = Math::BigRat->new('1 / 3'); # spaced
+ $x = Math::BigRat->new('1 / 0.1'); # w/ floats
+ $x = Math::BigRat->new(Math::BigInt->new(3)); # BigInt
+ $x = Math::BigRat->new(Math::BigFloat->new('3.1')); # BigFloat
+ $x = Math::BigRat->new(Math::BigInt::Lite->new('2')); # BigLite
+
+ # You can also give D and N as different objects:
+ $x = Math::BigRat->new(
+ Math::BigInt->new(-123),
+ Math::BigInt->new(7),
+ ); # => -123/7
+
+=head2 numerator()
+
+ $n = $x->numerator();
+
+Returns a copy of the numerator (the part above the line) as signed BigInt.
+
+=head2 denominator()
+
+ $d = $x->denominator();
+
+Returns a copy of the denominator (the part under the line) as positive BigInt.
+
+=head2 parts()
+
+ ($n,$d) = $x->parts();
+
+Return a list consisting of (signed) numerator and (unsigned) denominator as
+BigInts.
+
+=head2 numify()
+
+ my $y = $x->numify();
+
+Returns the object as a scalar. This will lose some data if the object
+cannot be represented by a normal Perl scalar (integer or float), so
+use L<as_int()> or L<as_float()> instead.
+
+This routine is automatically used whenever a scalar is required:
+
+ my $x = Math::BigRat->new('3/1');
+ @array = (0,1,2,3);
+ $y = $array[$x]; # set $y to 3
+
+=head2 as_int()/as_number()
+
+ $x = Math::BigRat->new('13/7');
+ print $x->as_int(),"\n"; # '1'
+
+Returns a copy of the object as BigInt, truncated to an integer.
+
+C<as_number()> is an alias for C<as_int()>.
+
+=head2 as_float()
+
+ $x = Math::BigRat->new('13/7');
+ print $x->as_float(),"\n"; # '1'
+
+ $x = Math::BigRat->new('2/3');
+ print $x->as_float(5),"\n"; # '0.66667'
+
+Returns a copy of the object as BigFloat, preserving the
+accuracy as wanted, or the default of 40 digits.
+
+This method was added in v0.22 of Math::BigRat (April 2008).
+
+=head2 as_hex()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_hex(),"\n"; # '0xd'
+
+Returns the BigRat as hexadecimal string. Works only for integers.
+
+=head2 as_bin()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_bin(),"\n"; # '0x1101'
+
+Returns the BigRat as binary string. Works only for integers.
+
+=head2 as_oct()
+
+ $x = Math::BigRat->new('13');
+ print $x->as_oct(),"\n"; # '015'
+
+Returns the BigRat as octal string. Works only for integers.
+
+=head2 from_hex()/from_bin()/from_oct()
+
+ my $h = Math::BigRat->from_hex('0x10');
+ my $b = Math::BigRat->from_bin('0b10000000');
+ my $o = Math::BigRat->from_oct('020');
+
+Create a BigRat from an hexadecimal, binary or octal number
+in string form.
+
+=head2 length()
+
+ $len = $x->length();
+
+Return the length of $x in digitis for integer values.
+
+=head2 digit()
+
+ print Math::BigRat->new('123/1')->digit(1); # 1
+ print Math::BigRat->new('123/1')->digit(-1); # 3
+
+Return the N'ths digit from X when X is an integer value.
+
+=head2 bnorm()
+
+ $x->bnorm();
+
+Reduce the number to the shortest form. This routine is called
+automatically whenever it is needed.
+
+=head2 bfac()
+
+ $x->bfac();
+
+Calculates the factorial of $x. For instance:
+
+ print Math::BigRat->new('3/1')->bfac(),"\n"; # 1*2*3
+ print Math::BigRat->new('5/1')->bfac(),"\n"; # 1*2*3*4*5
+
+Works currently only for integers.
+
+=head2 bround()/round()/bfround()
+
+Are not yet implemented.
+
+=head2 bmod()
+
+ use Math::BigRat;
+ my $x = Math::BigRat->new('7/4');
+ my $y = Math::BigRat->new('4/3');
+ print $x->bmod($y);
+
+Set $x to the remainder of the division of $x by $y.
+
+=head2 bneg()
+
+ $x->bneg();
+
+Used to negate the object in-place.
+
+=head2 is_one()
+
+ print "$x is 1\n" if $x->is_one();
+
+Return true if $x is exactly one, otherwise false.
+
+=head2 is_zero()
+
+ print "$x is 0\n" if $x->is_zero();
+
+Return true if $x is exactly zero, otherwise false.
+
+=head2 is_pos()/is_positive()
+
+ print "$x is >= 0\n" if $x->is_positive();
+
+Return true if $x is positive (greater than or equal to zero), otherwise
+false. Please note that '+inf' is also positive, while 'NaN' and '-inf' aren't.
+
+C<is_positive()> is an alias for C<is_pos()>.
+
+=head2 is_neg()/is_negative()
+
+ print "$x is < 0\n" if $x->is_negative();
+
+Return true if $x is negative (smaller than zero), otherwise false. Please
+note that '-inf' is also negative, while 'NaN' and '+inf' aren't.
+
+C<is_negative()> is an alias for C<is_neg()>.
+
+=head2 is_int()
+
+ print "$x is an integer\n" if $x->is_int();
+
+Return true if $x has a denominator of 1 (e.g. no fraction parts), otherwise
+false. Please note that '-inf', 'inf' and 'NaN' aren't integer.
+
+=head2 is_odd()
+
+ print "$x is odd\n" if $x->is_odd();
+
+Return true if $x is odd, otherwise false.
+
+=head2 is_even()
+
+ print "$x is even\n" if $x->is_even();
+
+Return true if $x is even, otherwise false.
+
+=head2 bceil()
+
+ $x->bceil();
+
+Set $x to the next bigger integer value (e.g. truncate the number to integer
+and then increment it by one).
+
+=head2 bfloor()
+
+ $x->bfloor();
+
+Truncate $x to an integer value.
+
+=head2 bsqrt()
+
+ $x->bsqrt();
+
+Calculate the square root of $x.
+
+=head2 broot()
+
+ $x->broot($n);
+
+Calculate the N'th root of $x.
+
+=head2 badd()/bmul()/bsub()/bdiv()/bdec()/binc()
+
+Please see the documentation in L<Math::BigInt>.
+
+=head2 copy()
+
+ my $z = $x->copy();
+
+Makes a deep copy of the object.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bstr()/bsstr()
+
+ my $x = Math::BigInt->new('8/4');
+ print $x->bstr(),"\n"; # prints 1/2
+ print $x->bsstr(),"\n"; # prints 1/2
+
+Return a string representating this object.
+
+=head2 bacmp()/bcmp()
+
+Used to compare numbers.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 blsft()/brsft()
+
+Used to shift numbers left/right.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bpow()
+
+ $x->bpow($y);
+
+Compute $x ** $y.
+
+Please see the documentation in L<Math::BigInt> for further details.
+
+=head2 bexp()
+
+ $x->bexp($accuracy); # calculate e ** X
+
+Calculates two integers A and B so that A/B is equal to C<e ** $x>, where C<e> is
+Euler's number.
+
+This method was added in v0.20 of Math::BigRat (May 2007).
+
+See also L<blog()>.
+
+=head2 bnok()
+
+ $x->bnok($y); # x over y (binomial coefficient n over k)
+
+Calculates the binomial coefficient n over k, also called the "choose"
+function. The result is equivalent to:
+
+ ( n ) n!
+ | - | = -------
+ ( k ) k!(n-k)!
+
+This method was added in v0.20 of Math::BigRat (May 2007).
+
+=head2 config()
+
+ use Data::Dumper;
+
+ print Dumper ( Math::BigRat->config() );
+ print Math::BigRat->config()->{lib},"\n";
+
+Returns a hash containing the configuration, e.g. the version number, lib
+loaded etc. The following hash keys are currently filled in with the
+appropriate information.
+
+ key RO/RW Description
+ Example
+ ============================================================
+ lib RO Name of the Math library
+ Math::BigInt::Calc
+ lib_version RO Version of 'lib'
+ 0.30
+ class RO The class of config you just called
+ Math::BigRat
+ version RO version number of the class you used
+ 0.10
+ upgrade RW To which class numbers are upgraded
+ undef
+ downgrade RW To which class numbers are downgraded
+ undef
+ precision RW Global precision
+ undef
+ accuracy RW Global accuracy
+ undef
+ round_mode RW Global round mode
+ even
+ div_scale RW Fallback accuracy for div
+ 40
+ trap_nan RW Trap creation of NaN (undef = no)
+ undef
+ trap_inf RW Trap creation of +inf/-inf (undef = no)
+ undef
+
+By passing a reference to a hash you may set the configuration values. This
+works only for values that a marked with a C<RW> above, anything else is
+read-only.
+
+=head2 objectify()
+
+This is an internal routine that turns scalars into objects.
+
+=head1 BUGS
+
+Some things are not yet implemented, or only implemented half-way:
+
+=over 2
+
+=item inf handling (partial)
+
+=item NaN handling (partial)
+
+=item rounding (not implemented except for bceil/bfloor)
+
+=item $x ** $y where $y is not an integer
+
+=item bmod(), blog(), bmodinv() and bmodpow() (partial)
+
+=back
+
+=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
+
+L<Math::BigFloat> and L<Math::Big> as well as L<Math::BigInt::BitVect>,
+L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+See L<http://search.cpan.org/search?dist=bignum> for a way to use
+Math::BigRat.
+
+The package at L<http://search.cpan.org/search?dist=Math%3A%3ABigRat>
+may contain more documentation and examples as well as testcases.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> 2001 - 2009.
+
+Currently maintained by Jonathan "Duke" Leto <jonathan@leto.net> L<http://leto.net>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Math/Complex.pm b/Master/tlpkg/tlperl/lib/Math/Complex.pm
new file mode 100644
index 00000000000..8475a2b5d09
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/Complex.pm
@@ -0,0 +1,2093 @@
+#
+# Complex numbers and associated mathematical functions
+# -- Raphael Manfredi Since Sep 1996
+# -- Jarkko Hietaniemi Since Mar 1997
+# -- Daniel S. Lewart Since Sep 1997
+#
+
+package Math::Complex;
+
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $Inf $ExpInf);
+
+$VERSION = 1.56;
+
+use Config;
+
+BEGIN {
+ my %DBL_MAX =
+ (
+ 4 => '1.70141183460469229e+38',
+ 8 => '1.7976931348623157e+308',
+ # AFAICT the 10, 12, and 16-byte long doubles
+ # all have the same maximum.
+ 10 => '1.1897314953572317650857593266280070162E+4932',
+ 12 => '1.1897314953572317650857593266280070162E+4932',
+ 16 => '1.1897314953572317650857593266280070162E+4932',
+ );
+ my $nvsize = $Config{nvsize} ||
+ ($Config{uselongdouble} && $Config{longdblsize}) ||
+ $Config{doublesize};
+ die "Math::Complex: Could not figure out nvsize\n"
+ unless defined $nvsize;
+ die "Math::Complex: Cannot not figure out max nv (nvsize = $nvsize)\n"
+ unless defined $DBL_MAX{$nvsize};
+ my $DBL_MAX = eval $DBL_MAX{$nvsize};
+ die "Math::Complex: Could not figure out max nv (nvsize = $nvsize)\n"
+ unless defined $DBL_MAX;
+ my $BIGGER_THAN_THIS = 1e30; # Must find something bigger than this.
+ if ($^O eq 'unicosmk') {
+ $Inf = $DBL_MAX;
+ } else {
+ local $SIG{FPE} = { };
+ local $!;
+ # We do want an arithmetic overflow, Inf INF inf Infinity.
+ for my $t (
+ 'exp(99999)', # Enough even with 128-bit long doubles.
+ 'inf',
+ 'Inf',
+ 'INF',
+ 'infinity',
+ 'Infinity',
+ 'INFINITY',
+ '1e99999',
+ ) {
+ local $^W = 0;
+ my $i = eval "$t+1.0";
+ if (defined $i && $i > $BIGGER_THAN_THIS) {
+ $Inf = $i;
+ last;
+ }
+ }
+ $Inf = $DBL_MAX unless defined $Inf; # Oh well, close enough.
+ die "Math::Complex: Could not get Infinity"
+ unless $Inf > $BIGGER_THAN_THIS;
+ $ExpInf = exp(99999);
+ }
+ # print "# On this machine, Inf = '$Inf'\n";
+}
+
+use Scalar::Util qw(set_prototype);
+
+use warnings;
+no warnings 'syntax'; # To avoid the (_) warnings.
+
+BEGIN {
+ # For certain functions that we override, in 5.10 or better
+ # we can set a smarter prototype that will handle the lexical $_
+ # (also a 5.10+ feature).
+ if ($] >= 5.010000) {
+ set_prototype \&abs, '_';
+ set_prototype \&cos, '_';
+ set_prototype \&exp, '_';
+ set_prototype \&log, '_';
+ set_prototype \&sin, '_';
+ set_prototype \&sqrt, '_';
+ }
+}
+
+my $i;
+my %LOGN;
+
+# Regular expression for floating point numbers.
+# These days we could use Scalar::Util::lln(), I guess.
+my $gre = qr'\s*([\+\-]?(?:(?:(?:\d+(?:_\d+)*(?:\.\d*(?:_\d+)*)?|\.\d+(?:_\d+)*)(?:[eE][\+\-]?\d+(?:_\d+)*)?))|inf)'i;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+my @trig = qw(
+ pi
+ tan
+ csc cosec sec cot cotan
+ asin acos atan
+ acsc acosec asec acot acotan
+ sinh cosh tanh
+ csch cosech sech coth cotanh
+ asinh acosh atanh
+ acsch acosech asech acoth acotanh
+ );
+
+@EXPORT = (qw(
+ i Re Im rho theta arg
+ sqrt log ln
+ log10 logn cbrt root
+ cplx cplxe
+ atan2
+ ),
+ @trig);
+
+my @pi = qw(pi pi2 pi4 pip2 pip4 Inf);
+
+@EXPORT_OK = @pi;
+
+%EXPORT_TAGS = (
+ 'trig' => [@trig],
+ 'pi' => [@pi],
+);
+
+use overload
+ '+' => \&_plus,
+ '-' => \&_minus,
+ '*' => \&_multiply,
+ '/' => \&_divide,
+ '**' => \&_power,
+ '==' => \&_numeq,
+ '<=>' => \&_spaceship,
+ 'neg' => \&_negate,
+ '~' => \&_conjugate,
+ 'abs' => \&abs,
+ 'sqrt' => \&sqrt,
+ 'exp' => \&exp,
+ 'log' => \&log,
+ 'sin' => \&sin,
+ 'cos' => \&cos,
+ 'tan' => \&tan,
+ 'atan2' => \&atan2,
+ '""' => \&_stringify;
+
+#
+# Package "privates"
+#
+
+my %DISPLAY_FORMAT = ('style' => 'cartesian',
+ 'polar_pretty_print' => 1);
+my $eps = 1e-14; # Epsilon
+
+#
+# Object attributes (internal):
+# cartesian [real, imaginary] -- cartesian form
+# polar [rho, theta] -- polar form
+# c_dirty cartesian form not up-to-date
+# p_dirty polar form not up-to-date
+# display display format (package's global when not set)
+#
+
+# Die on bad *make() arguments.
+
+sub _cannot_make {
+ die "@{[(caller(1))[3]]}: Cannot take $_[0] of '$_[1]'.\n";
+}
+
+sub _make {
+ my $arg = shift;
+ my ($p, $q);
+
+ if ($arg =~ /^$gre$/) {
+ ($p, $q) = ($1, 0);
+ } elsif ($arg =~ /^(?:$gre)?$gre\s*i\s*$/) {
+ ($p, $q) = ($1 || 0, $2);
+ } elsif ($arg =~ /^\s*\(\s*$gre\s*(?:,\s*$gre\s*)?\)\s*$/) {
+ ($p, $q) = ($1, $2 || 0);
+ }
+
+ if (defined $p) {
+ $p =~ s/^\+//;
+ $p =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ $q =~ s/^\+//;
+ $q =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ }
+
+ return ($p, $q);
+}
+
+sub _emake {
+ my $arg = shift;
+ my ($p, $q);
+
+ if ($arg =~ /^\s*\[\s*$gre\s*(?:,\s*$gre\s*)?\]\s*$/) {
+ ($p, $q) = ($1, $2 || 0);
+ } elsif ($arg =~ m!^\s*\[\s*$gre\s*(?:,\s*([-+]?\d*\s*)?pi(?:/\s*(\d+))?\s*)?\]\s*$!) {
+ ($p, $q) = ($1, ($2 eq '-' ? -1 : ($2 || 1)) * pi() / ($3 || 1));
+ } elsif ($arg =~ /^\s*\[\s*$gre\s*\]\s*$/) {
+ ($p, $q) = ($1, 0);
+ } elsif ($arg =~ /^\s*$gre\s*$/) {
+ ($p, $q) = ($1, 0);
+ }
+
+ if (defined $p) {
+ $p =~ s/^\+//;
+ $q =~ s/^\+//;
+ $p =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ $q =~ s/^(-?)inf$/"${1}9**9**9"/e;
+ }
+
+ return ($p, $q);
+}
+
+#
+# ->make
+#
+# Create a new complex number (cartesian form)
+#
+sub make {
+ my $self = bless {}, shift;
+ my ($re, $im);
+ if (@_ == 0) {
+ ($re, $im) = (0, 0);
+ } elsif (@_ == 1) {
+ return (ref $self)->emake($_[0])
+ if ($_[0] =~ /^\s*\[/);
+ ($re, $im) = _make($_[0]);
+ } elsif (@_ == 2) {
+ ($re, $im) = @_;
+ }
+ if (defined $re) {
+ _cannot_make("real part", $re) unless $re =~ /^$gre$/;
+ }
+ $im ||= 0;
+ _cannot_make("imaginary part", $im) unless $im =~ /^$gre$/;
+ $self->_set_cartesian([$re, $im ]);
+ $self->display_format('cartesian');
+
+ return $self;
+}
+
+#
+# ->emake
+#
+# Create a new complex number (exponential form)
+#
+sub emake {
+ my $self = bless {}, shift;
+ my ($rho, $theta);
+ if (@_ == 0) {
+ ($rho, $theta) = (0, 0);
+ } elsif (@_ == 1) {
+ return (ref $self)->make($_[0])
+ if ($_[0] =~ /^\s*\(/ || $_[0] =~ /i\s*$/);
+ ($rho, $theta) = _emake($_[0]);
+ } elsif (@_ == 2) {
+ ($rho, $theta) = @_;
+ }
+ if (defined $rho && defined $theta) {
+ if ($rho < 0) {
+ $rho = -$rho;
+ $theta = ($theta <= 0) ? $theta + pi() : $theta - pi();
+ }
+ }
+ if (defined $rho) {
+ _cannot_make("rho", $rho) unless $rho =~ /^$gre$/;
+ }
+ $theta ||= 0;
+ _cannot_make("theta", $theta) unless $theta =~ /^$gre$/;
+ $self->_set_polar([$rho, $theta]);
+ $self->display_format('polar');
+
+ return $self;
+}
+
+sub new { &make } # For backward compatibility only.
+
+#
+# cplx
+#
+# Creates a complex number from a (re, im) tuple.
+# This avoids the burden of writing Math::Complex->make(re, im).
+#
+sub cplx {
+ return __PACKAGE__->make(@_);
+}
+
+#
+# cplxe
+#
+# Creates a complex number from a (rho, theta) tuple.
+# This avoids the burden of writing Math::Complex->emake(rho, theta).
+#
+sub cplxe {
+ return __PACKAGE__->emake(@_);
+}
+
+#
+# pi
+#
+# The number defined as pi = 180 degrees
+#
+sub pi () { 4 * CORE::atan2(1, 1) }
+
+#
+# pi2
+#
+# The full circle
+#
+sub pi2 () { 2 * pi }
+
+#
+# pi4
+#
+# The full circle twice.
+#
+sub pi4 () { 4 * pi }
+
+#
+# pip2
+#
+# The quarter circle
+#
+sub pip2 () { pi / 2 }
+
+#
+# pip4
+#
+# The eighth circle.
+#
+sub pip4 () { pi / 4 }
+
+#
+# _uplog10
+#
+# Used in log10().
+#
+sub _uplog10 () { 1 / CORE::log(10) }
+
+#
+# i
+#
+# The number defined as i*i = -1;
+#
+sub i () {
+ return $i if ($i);
+ $i = bless {};
+ $i->{'cartesian'} = [0, 1];
+ $i->{'polar'} = [1, pip2];
+ $i->{c_dirty} = 0;
+ $i->{p_dirty} = 0;
+ return $i;
+}
+
+#
+# _ip2
+#
+# Half of i.
+#
+sub _ip2 () { i / 2 }
+
+#
+# Attribute access/set routines
+#
+
+sub _cartesian {$_[0]->{c_dirty} ?
+ $_[0]->_update_cartesian : $_[0]->{'cartesian'}}
+sub _polar {$_[0]->{p_dirty} ?
+ $_[0]->_update_polar : $_[0]->{'polar'}}
+
+sub _set_cartesian { $_[0]->{p_dirty}++; $_[0]->{c_dirty} = 0;
+ $_[0]->{'cartesian'} = $_[1] }
+sub _set_polar { $_[0]->{c_dirty}++; $_[0]->{p_dirty} = 0;
+ $_[0]->{'polar'} = $_[1] }
+
+#
+# ->_update_cartesian
+#
+# Recompute and return the cartesian form, given accurate polar form.
+#
+sub _update_cartesian {
+ my $self = shift;
+ my ($r, $t) = @{$self->{'polar'}};
+ $self->{c_dirty} = 0;
+ return $self->{'cartesian'} = [$r * CORE::cos($t), $r * CORE::sin($t)];
+}
+
+#
+#
+# ->_update_polar
+#
+# Recompute and return the polar form, given accurate cartesian form.
+#
+sub _update_polar {
+ my $self = shift;
+ my ($x, $y) = @{$self->{'cartesian'}};
+ $self->{p_dirty} = 0;
+ return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0;
+ return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y),
+ CORE::atan2($y, $x)];
+}
+
+#
+# (_plus)
+#
+# Computes z1+z2.
+#
+sub _plus {
+ my ($z1, $z2, $regular) = @_;
+ my ($re1, $im1) = @{$z1->_cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ unless (defined $regular) {
+ $z1->_set_cartesian([$re1 + $re2, $im1 + $im2]);
+ return $z1;
+ }
+ return (ref $z1)->make($re1 + $re2, $im1 + $im2);
+}
+
+#
+# (_minus)
+#
+# Computes z1-z2.
+#
+sub _minus {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = @{$z1->_cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = @{$z2->_cartesian};
+ unless (defined $inverted) {
+ $z1->_set_cartesian([$re1 - $re2, $im1 - $im2]);
+ return $z1;
+ }
+ return $inverted ?
+ (ref $z1)->make($re2 - $re1, $im2 - $im1) :
+ (ref $z1)->make($re1 - $re2, $im1 - $im2);
+
+}
+
+#
+# (_multiply)
+#
+# Computes z1*z2.
+#
+sub _multiply {
+ my ($z1, $z2, $regular) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->_polar};
+ my ($r2, $t2) = @{$z2->_polar};
+ my $t = $t1 + $t2;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ unless (defined $regular) {
+ $z1->_set_polar([$r1 * $r2, $t]);
+ return $z1;
+ }
+ return (ref $z1)->emake($r1 * $r2, $t);
+ } else {
+ my ($x1, $y1) = @{$z1->_cartesian};
+ if (ref $z2) {
+ my ($x2, $y2) = @{$z2->_cartesian};
+ return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2);
+ } else {
+ return (ref $z1)->make($x1*$z2, $y1*$z2);
+ }
+ }
+}
+
+#
+# _divbyzero
+#
+# Die on division by zero.
+#
+sub _divbyzero {
+ my $mess = "$_[0]: Division by zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the divisor ";
+ $mess .= "$_[1] " unless ("$_[1]" eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (_divide)
+#
+# Computes z1/z2.
+#
+sub _divide {
+ my ($z1, $z2, $inverted) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->_polar};
+ my ($r2, $t2) = @{$z2->_polar};
+ my $t;
+ if ($inverted) {
+ _divbyzero "$z2/0" if ($r1 == 0);
+ $t = $t2 - $t1;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z1)->emake($r2 / $r1, $t);
+ } else {
+ _divbyzero "$z1/0" if ($r2 == 0);
+ $t = $t1 - $t2;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z1)->emake($r1 / $r2, $t);
+ }
+ } else {
+ my ($d, $x2, $y2);
+ if ($inverted) {
+ ($x2, $y2) = @{$z1->_cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z2/0" if $d == 0;
+ return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d);
+ } else {
+ my ($x1, $y1) = @{$z1->_cartesian};
+ if (ref $z2) {
+ ($x2, $y2) = @{$z2->_cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z1/0" if $d == 0;
+ my $u = ($x1*$x2 + $y1*$y2)/$d;
+ my $v = ($y1*$x2 - $x1*$y2)/$d;
+ return (ref $z1)->make($u, $v);
+ } else {
+ _divbyzero "$z1/0" if $z2 == 0;
+ return (ref $z1)->make($x1/$z2, $y1/$z2);
+ }
+ }
+ }
+}
+
+#
+# (_power)
+#
+# Computes z1**z2 = exp(z2 * log z1)).
+#
+sub _power {
+ my ($z1, $z2, $inverted) = @_;
+ if ($inverted) {
+ return 1 if $z1 == 0 || $z2 == 1;
+ return 0 if $z2 == 0 && Re($z1) > 0;
+ } else {
+ return 1 if $z2 == 0 || $z1 == 1;
+ return 0 if $z1 == 0 && Re($z2) > 0;
+ }
+ my $w = $inverted ? &exp($z1 * &log($z2))
+ : &exp($z2 * &log($z1));
+ # If both arguments cartesian, return cartesian, else polar.
+ return $z1->{c_dirty} == 0 &&
+ (not ref $z2 or $z2->{c_dirty} == 0) ?
+ cplx(@{$w->_cartesian}) : $w;
+}
+
+#
+# (_spaceship)
+#
+# Computes z1 <=> z2.
+# Sorts on the real part first, then on the imaginary part. Thus 2-4i < 3+8i.
+#
+sub _spaceship {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ my $sgn = $inverted ? -1 : 1;
+ return $sgn * ($re1 <=> $re2) if $re1 != $re2;
+ return $sgn * ($im1 <=> $im2);
+}
+
+#
+# (_numeq)
+#
+# Computes z1 == z2.
+#
+# (Required in addition to _spaceship() because of NaNs.)
+sub _numeq {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ my ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ return $re1 == $re2 && $im1 == $im2 ? 1 : 0;
+}
+
+#
+# (_negate)
+#
+# Computes -z.
+#
+sub _negate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->_polar};
+ $t = ($t <= 0) ? $t + pi : $t - pi;
+ return (ref $z)->emake($r, $t);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ return (ref $z)->make(-$re, -$im);
+}
+
+#
+# (_conjugate)
+#
+# Compute complex's _conjugate.
+#
+sub _conjugate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->_polar};
+ return (ref $z)->emake($r, -$t);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ return (ref $z)->make($re, -$im);
+}
+
+#
+# (abs)
+#
+# Compute or set complex's norm (rho).
+#
+sub abs {
+ my ($z, $rho) = @_ ? @_ : $_;
+ unless (ref $z) {
+ if (@_ == 2) {
+ $_[0] = $_[1];
+ } else {
+ return CORE::abs($z);
+ }
+ }
+ if (defined $rho) {
+ $z->{'polar'} = [ $rho, ${$z->_polar}[1] ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ return $rho;
+ } else {
+ return ${$z->_polar}[0];
+ }
+}
+
+sub _theta {
+ my $theta = $_[0];
+
+ if ($$theta > pi()) { $$theta -= pi2 }
+ elsif ($$theta <= -pi()) { $$theta += pi2 }
+}
+
+#
+# arg
+#
+# Compute or set complex's argument (theta).
+#
+sub arg {
+ my ($z, $theta) = @_;
+ return $z unless ref $z;
+ if (defined $theta) {
+ _theta(\$theta);
+ $z->{'polar'} = [ ${$z->_polar}[0], $theta ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ } else {
+ $theta = ${$z->_polar}[1];
+ _theta(\$theta);
+ }
+ return $theta;
+}
+
+#
+# (sqrt)
+#
+# Compute sqrt(z).
+#
+# It is quite tempting to use wantarray here so that in list context
+# sqrt() would return the two solutions. This, however, would
+# break things like
+#
+# print "sqrt(z) = ", sqrt($z), "\n";
+#
+# The two values would be printed side by side without no intervening
+# whitespace, quite confusing.
+# Therefore if you want the two solutions use the root().
+#
+sub sqrt {
+ my ($z) = @_ ? $_[0] : $_;
+ my ($re, $im) = ref $z ? @{$z->_cartesian} : ($z, 0);
+ return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re)
+ if $im == 0;
+ my ($r, $t) = @{$z->_polar};
+ return (ref $z)->emake(CORE::sqrt($r), $t/2);
+}
+
+#
+# cbrt
+#
+# Compute cbrt(z) (cubic root).
+#
+# Why are we not returning three values? The same answer as for sqrt().
+#
+sub cbrt {
+ my ($z) = @_;
+ return $z < 0 ?
+ -CORE::exp(CORE::log(-$z)/3) :
+ ($z > 0 ? CORE::exp(CORE::log($z)/3): 0)
+ unless ref $z;
+ my ($r, $t) = @{$z->_polar};
+ return 0 if $r == 0;
+ return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3);
+}
+
+#
+# _rootbad
+#
+# Die on bad root.
+#
+sub _rootbad {
+ my $mess = "Root '$_[0]' illegal, root rank must be positive integer.\n";
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# root
+#
+# Computes all nth root for z, returning an array whose size is n.
+# `n' must be a positive integer.
+#
+# The roots are given by (for k = 0..n-1):
+#
+# z^(1/n) = r^(1/n) (cos ((t+2 k pi)/n) + i sin ((t+2 k pi)/n))
+#
+sub root {
+ my ($z, $n, $k) = @_;
+ _rootbad($n) if ($n < 1 or int($n) != $n);
+ my ($r, $t) = ref $z ?
+ @{$z->_polar} : (CORE::abs($z), $z >= 0 ? 0 : pi);
+ my $theta_inc = pi2 / $n;
+ my $rho = $r ** (1/$n);
+ my $cartesian = ref $z && $z->{c_dirty} == 0;
+ if (@_ == 2) {
+ my @root;
+ for (my $i = 0, my $theta = $t / $n;
+ $i < $n;
+ $i++, $theta += $theta_inc) {
+ my $w = cplxe($rho, $theta);
+ # Yes, $cartesian is loop invariant.
+ push @root, $cartesian ? cplx(@{$w->_cartesian}) : $w;
+ }
+ return @root;
+ } elsif (@_ == 3) {
+ my $w = cplxe($rho, $t / $n + $k * $theta_inc);
+ return $cartesian ? cplx(@{$w->_cartesian}) : $w;
+ }
+}
+
+#
+# Re
+#
+# Return or set Re(z).
+#
+sub Re {
+ my ($z, $Re) = @_;
+ return $z unless ref $z;
+ if (defined $Re) {
+ $z->{'cartesian'} = [ $Re, ${$z->_cartesian}[1] ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->_cartesian}[0];
+ }
+}
+
+#
+# Im
+#
+# Return or set Im(z).
+#
+sub Im {
+ my ($z, $Im) = @_;
+ return 0 unless ref $z;
+ if (defined $Im) {
+ $z->{'cartesian'} = [ ${$z->_cartesian}[0], $Im ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->_cartesian}[1];
+ }
+}
+
+#
+# rho
+#
+# Return or set rho(w).
+#
+sub rho {
+ Math::Complex::abs(@_);
+}
+
+#
+# theta
+#
+# Return or set theta(w).
+#
+sub theta {
+ Math::Complex::arg(@_);
+}
+
+#
+# (exp)
+#
+# Computes exp(z).
+#
+sub exp {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::exp($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return (ref $z)->emake(CORE::exp($x), $y);
+}
+
+#
+# _logofzero
+#
+# Die on logarithm of zero.
+#
+sub _logofzero {
+ my $mess = "$_[0]: Logarithm of zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the argument ";
+ $mess .= "$_[1] " unless ($_[1] eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (log)
+#
+# Compute log(z).
+#
+sub log {
+ my ($z) = @_ ? @_ : $_;
+ unless (ref $z) {
+ _logofzero("log") if $z == 0;
+ return $z > 0 ? CORE::log($z) : cplx(CORE::log(-$z), pi);
+ }
+ my ($r, $t) = @{$z->_polar};
+ _logofzero("log") if $r == 0;
+ if ($t > pi()) { $t -= pi2 }
+ elsif ($t <= -pi()) { $t += pi2 }
+ return (ref $z)->make(CORE::log($r), $t);
+}
+
+#
+# ln
+#
+# Alias for log().
+#
+sub ln { Math::Complex::log(@_) }
+
+#
+# log10
+#
+# Compute log10(z).
+#
+
+sub log10 {
+ return Math::Complex::log($_[0]) * _uplog10;
+}
+
+#
+# logn
+#
+# Compute logn(z,n) = log(z) / log(n)
+#
+sub logn {
+ my ($z, $n) = @_;
+ $z = cplx($z, 0) unless ref $z;
+ my $logn = $LOGN{$n};
+ $logn = $LOGN{$n} = CORE::log($n) unless defined $logn; # Cache log(n)
+ return &log($z) / $logn;
+}
+
+#
+# (cos)
+#
+# Compute cos(z) = (exp(iz) + exp(-iz))/2.
+#
+sub cos {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::cos($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ my $ey = CORE::exp($y);
+ my $sx = CORE::sin($x);
+ my $cx = CORE::cos($x);
+ my $ey_1 = $ey ? 1 / $ey : Inf();
+ return (ref $z)->make($cx * ($ey + $ey_1)/2,
+ $sx * ($ey_1 - $ey)/2);
+}
+
+#
+# (sin)
+#
+# Compute sin(z) = (exp(iz) - exp(-iz))/2.
+#
+sub sin {
+ my ($z) = @_ ? @_ : $_;
+ return CORE::sin($z) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ my $ey = CORE::exp($y);
+ my $sx = CORE::sin($x);
+ my $cx = CORE::cos($x);
+ my $ey_1 = $ey ? 1 / $ey : Inf();
+ return (ref $z)->make($sx * ($ey + $ey_1)/2,
+ $cx * ($ey - $ey_1)/2);
+}
+
+#
+# tan
+#
+# Compute tan(z) = sin(z) / cos(z).
+#
+sub tan {
+ my ($z) = @_;
+ my $cz = &cos($z);
+ _divbyzero "tan($z)", "cos($z)" if $cz == 0;
+ return &sin($z) / $cz;
+}
+
+#
+# sec
+#
+# Computes the secant sec(z) = 1 / cos(z).
+#
+sub sec {
+ my ($z) = @_;
+ my $cz = &cos($z);
+ _divbyzero "sec($z)", "cos($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csc
+#
+# Computes the cosecant csc(z) = 1 / sin(z).
+#
+sub csc {
+ my ($z) = @_;
+ my $sz = &sin($z);
+ _divbyzero "csc($z)", "sin($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosec
+#
+# Alias for csc().
+#
+sub cosec { Math::Complex::csc(@_) }
+
+#
+# cot
+#
+# Computes cot(z) = cos(z) / sin(z).
+#
+sub cot {
+ my ($z) = @_;
+ my $sz = &sin($z);
+ _divbyzero "cot($z)", "sin($z)" if ($sz == 0);
+ return &cos($z) / $sz;
+}
+
+#
+# cotan
+#
+# Alias for cot().
+#
+sub cotan { Math::Complex::cot(@_) }
+
+#
+# acos
+#
+# Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)).
+#
+sub acos {
+ my $z = $_[0];
+ return CORE::atan2(CORE::sqrt(1-$z*$z), $z)
+ if (! ref $z) && CORE::abs($z) <= 1;
+ $z = cplx($z, 0) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return 0 if $x == 1 && $y == 0;
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta);
+ my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return (ref $z)->make($u, $v);
+}
+
+#
+# asin
+#
+# Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)).
+#
+sub asin {
+ my $z = $_[0];
+ return CORE::atan2($z, CORE::sqrt(1-$z*$z))
+ if (! ref $z) && CORE::abs($z) <= 1;
+ $z = cplx($z, 0) unless ref $z;
+ my ($x, $y) = @{$z->_cartesian};
+ return 0 if $x == 0 && $y == 0;
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta));
+ my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return (ref $z)->make($u, $v);
+}
+
+#
+# atan
+#
+# Computes the arc tangent atan(z) = i/2 log((i+z) / (i-z)).
+#
+sub atan {
+ my ($z) = @_;
+ return CORE::atan2($z, 1) unless ref $z;
+ my ($x, $y) = ref $z ? @{$z->_cartesian} : ($z, 0);
+ return 0 if $x == 0 && $y == 0;
+ _divbyzero "atan(i)" if ( $z == i);
+ _logofzero "atan(-i)" if (-$z == i); # -i is a bad file test...
+ my $log = &log((i + $z) / (i - $z));
+ return _ip2 * $log;
+}
+
+#
+# asec
+#
+# Computes the arc secant asec(z) = acos(1 / z).
+#
+sub asec {
+ my ($z) = @_;
+ _divbyzero "asec($z)", $z if ($z == 0);
+ return acos(1 / $z);
+}
+
+#
+# acsc
+#
+# Computes the arc cosecant acsc(z) = asin(1 / z).
+#
+sub acsc {
+ my ($z) = @_;
+ _divbyzero "acsc($z)", $z if ($z == 0);
+ return asin(1 / $z);
+}
+
+#
+# acosec
+#
+# Alias for acsc().
+#
+sub acosec { Math::Complex::acsc(@_) }
+
+#
+# acot
+#
+# Computes the arc cotangent acot(z) = atan(1 / z)
+#
+sub acot {
+ my ($z) = @_;
+ _divbyzero "acot(0)" if $z == 0;
+ return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z)
+ unless ref $z;
+ _divbyzero "acot(i)" if ($z - i == 0);
+ _logofzero "acot(-i)" if ($z + i == 0);
+ return atan(1 / $z);
+}
+
+#
+# acotan
+#
+# Alias for acot().
+#
+sub acotan { Math::Complex::acot(@_) }
+
+#
+# cosh
+#
+# Computes the hyperbolic cosine cosh(z) = (exp(z) + exp(-z))/2.
+#
+sub cosh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ $ex = CORE::exp($z);
+ return $ex ? ($ex == $ExpInf ? Inf() : ($ex + 1/$ex)/2) : Inf();
+ }
+ my ($x, $y) = @{$z->_cartesian};
+ $ex = CORE::exp($x);
+ my $ex_1 = $ex ? 1 / $ex : Inf();
+ return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2,
+ CORE::sin($y) * ($ex - $ex_1)/2);
+}
+
+#
+# sinh
+#
+# Computes the hyperbolic sine sinh(z) = (exp(z) - exp(-z))/2.
+#
+sub sinh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ return 0 if $z == 0;
+ $ex = CORE::exp($z);
+ return $ex ? ($ex == $ExpInf ? Inf() : ($ex - 1/$ex)/2) : -Inf();
+ }
+ my ($x, $y) = @{$z->_cartesian};
+ my $cy = CORE::cos($y);
+ my $sy = CORE::sin($y);
+ $ex = CORE::exp($x);
+ my $ex_1 = $ex ? 1 / $ex : Inf();
+ return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2,
+ CORE::sin($y) * ($ex + $ex_1)/2);
+}
+
+#
+# tanh
+#
+# Computes the hyperbolic tangent tanh(z) = sinh(z) / cosh(z).
+#
+sub tanh {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "tanh($z)", "cosh($z)" if ($cz == 0);
+ my $sz = sinh($z);
+ return 1 if $cz == $sz;
+ return -1 if $cz == -$sz;
+ return $sz / $cz;
+}
+
+#
+# sech
+#
+# Computes the hyperbolic secant sech(z) = 1 / cosh(z).
+#
+sub sech {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "sech($z)", "cosh($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csch
+#
+# Computes the hyperbolic cosecant csch(z) = 1 / sinh(z).
+#
+sub csch {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "csch($z)", "sinh($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosech
+#
+# Alias for csch().
+#
+sub cosech { Math::Complex::csch(@_) }
+
+#
+# coth
+#
+# Computes the hyperbolic cotangent coth(z) = cosh(z) / sinh(z).
+#
+sub coth {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "coth($z)", "sinh($z)" if $sz == 0;
+ my $cz = cosh($z);
+ return 1 if $cz == $sz;
+ return -1 if $cz == -$sz;
+ return $cz / $sz;
+}
+
+#
+# cotanh
+#
+# Alias for coth().
+#
+sub cotanh { Math::Complex::coth(@_) }
+
+#
+# acosh
+#
+# Computes the area/inverse hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)).
+#
+sub acosh {
+ my ($z) = @_;
+ unless (ref $z) {
+ $z = cplx($z, 0);
+ }
+ my ($re, $im) = @{$z->_cartesian};
+ if ($im == 0) {
+ return CORE::log($re + CORE::sqrt($re*$re - 1))
+ if $re >= 1;
+ return cplx(0, CORE::atan2(CORE::sqrt(1 - $re*$re), $re))
+ if CORE::abs($re) < 1;
+ }
+ my $t = &sqrt($z * $z - 1) + $z;
+ # Try Taylor if looking bad (this usually means that
+ # $z was large negative, therefore the sqrt is really
+ # close to abs(z), summing that with z...)
+ $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7)
+ if $t == 0;
+ my $u = &log($t);
+ $u->Im(-$u->Im) if $re < 0 && $im == 0;
+ return $re < 0 ? -$u : $u;
+}
+
+#
+# asinh
+#
+# Computes the area/inverse hyperbolic sine asinh(z) = log(z + sqrt(z*z+1))
+#
+sub asinh {
+ my ($z) = @_;
+ unless (ref $z) {
+ my $t = $z + CORE::sqrt($z*$z + 1);
+ return CORE::log($t) if $t;
+ }
+ my $t = &sqrt($z * $z + 1) + $z;
+ # Try Taylor if looking bad (this usually means that
+ # $z was large negative, therefore the sqrt is really
+ # close to abs(z), summing that with z...)
+ $t = 1/(2 * $z) - 1/(8 * $z**3) + 1/(16 * $z**5) - 5/(128 * $z**7)
+ if $t == 0;
+ return &log($t);
+}
+
+#
+# atanh
+#
+# Computes the area/inverse hyperbolic tangent atanh(z) = 1/2 log((1+z) / (1-z)).
+#
+sub atanh {
+ my ($z) = @_;
+ unless (ref $z) {
+ return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'atanh(1)', "1 - $z" if (1 - $z == 0);
+ _logofzero 'atanh(-1)' if (1 + $z == 0);
+ return 0.5 * &log((1 + $z) / (1 - $z));
+}
+
+#
+# asech
+#
+# Computes the area/inverse hyperbolic secant asech(z) = acosh(1 / z).
+#
+sub asech {
+ my ($z) = @_;
+ _divbyzero 'asech(0)', "$z" if ($z == 0);
+ return acosh(1 / $z);
+}
+
+#
+# acsch
+#
+# Computes the area/inverse hyperbolic cosecant acsch(z) = asinh(1 / z).
+#
+sub acsch {
+ my ($z) = @_;
+ _divbyzero 'acsch(0)', $z if ($z == 0);
+ return asinh(1 / $z);
+}
+
+#
+# acosech
+#
+# Alias for acosh().
+#
+sub acosech { Math::Complex::acsch(@_) }
+
+#
+# acoth
+#
+# Computes the area/inverse hyperbolic cotangent acoth(z) = 1/2 log((1+z) / (z-1)).
+#
+sub acoth {
+ my ($z) = @_;
+ _divbyzero 'acoth(0)' if ($z == 0);
+ unless (ref $z) {
+ return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'acoth(1)', "$z - 1" if ($z - 1 == 0);
+ _logofzero 'acoth(-1)', "1 + $z" if (1 + $z == 0);
+ return &log((1 + $z) / ($z - 1)) / 2;
+}
+
+#
+# acotanh
+#
+# Alias for acot().
+#
+sub acotanh { Math::Complex::acoth(@_) }
+
+#
+# (atan2)
+#
+# Compute atan(z1/z2), minding the right quadrant.
+#
+sub atan2 {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1, $re2, $im2);
+ if ($inverted) {
+ ($re1, $im1) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ ($re2, $im2) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ } else {
+ ($re1, $im1) = ref $z1 ? @{$z1->_cartesian} : ($z1, 0);
+ ($re2, $im2) = ref $z2 ? @{$z2->_cartesian} : ($z2, 0);
+ }
+ if ($im1 || $im2) {
+ # In MATLAB the imaginary parts are ignored.
+ # warn "atan2: Imaginary parts ignored";
+ # http://documents.wolfram.com/mathematica/functions/ArcTan
+ # NOTE: Mathematica ArcTan[x,y] while atan2(y,x)
+ my $s = $z1 * $z1 + $z2 * $z2;
+ _divbyzero("atan2") if $s == 0;
+ my $i = &i;
+ my $r = $z2 + $z1 * $i;
+ return -$i * &log($r / &sqrt( $s ));
+ }
+ return CORE::atan2($re1, $re2);
+}
+
+#
+# display_format
+# ->display_format
+#
+# Set (get if no argument) the display format for all complex numbers that
+# don't happen to have overridden it via ->display_format
+#
+# When called as an object method, this actually sets the display format for
+# the current object.
+#
+# Valid object formats are 'c' and 'p' for cartesian and polar. The first
+# letter is used actually, so the type can be fully spelled out for clarity.
+#
+sub display_format {
+ my $self = shift;
+ my %display_format = %DISPLAY_FORMAT;
+
+ if (ref $self) { # Called as an object method
+ if (exists $self->{display_format}) {
+ my %obj = %{$self->{display_format}};
+ @display_format{keys %obj} = values %obj;
+ }
+ }
+ if (@_ == 1) {
+ $display_format{style} = shift;
+ } else {
+ my %new = @_;
+ @display_format{keys %new} = values %new;
+ }
+
+ if (ref $self) { # Called as an object method
+ $self->{display_format} = { %display_format };
+ return
+ wantarray ?
+ %{$self->{display_format}} :
+ $self->{display_format}->{style};
+ }
+
+ # Called as a class method
+ %DISPLAY_FORMAT = %display_format;
+ return
+ wantarray ?
+ %DISPLAY_FORMAT :
+ $DISPLAY_FORMAT{style};
+}
+
+#
+# (_stringify)
+#
+# Show nicely formatted complex number under its cartesian or polar form,
+# depending on the current display format:
+#
+# . If a specific display format has been recorded for this object, use it.
+# . Otherwise, use the generic current default for all complex numbers,
+# which is a package global variable.
+#
+sub _stringify {
+ my ($z) = shift;
+
+ my $style = $z->display_format;
+
+ $style = $DISPLAY_FORMAT{style} unless defined $style;
+
+ return $z->_stringify_polar if $style =~ /^p/i;
+ return $z->_stringify_cartesian;
+}
+
+#
+# ->_stringify_cartesian
+#
+# Stringify as a cartesian representation 'a+bi'.
+#
+sub _stringify_cartesian {
+ my $z = shift;
+ my ($x, $y) = @{$z->_cartesian};
+ my ($re, $im);
+
+ my %format = $z->display_format;
+ my $format = $format{format};
+
+ if ($x) {
+ if ($x =~ /^NaN[QS]?$/i) {
+ $re = $x;
+ } else {
+ if ($x =~ /^-?\Q$Inf\E$/oi) {
+ $re = $x;
+ } else {
+ $re = defined $format ? sprintf($format, $x) : $x;
+ }
+ }
+ } else {
+ undef $re;
+ }
+
+ if ($y) {
+ if ($y =~ /^(NaN[QS]?)$/i) {
+ $im = $y;
+ } else {
+ if ($y =~ /^-?\Q$Inf\E$/oi) {
+ $im = $y;
+ } else {
+ $im =
+ defined $format ?
+ sprintf($format, $y) :
+ ($y == 1 ? "" : ($y == -1 ? "-" : $y));
+ }
+ }
+ $im .= "i";
+ } else {
+ undef $im;
+ }
+
+ my $str = $re;
+
+ if (defined $im) {
+ if ($y < 0) {
+ $str .= $im;
+ } elsif ($y > 0 || $im =~ /^NaN[QS]?i$/i) {
+ $str .= "+" if defined $re;
+ $str .= $im;
+ }
+ } elsif (!defined $re) {
+ $str = "0";
+ }
+
+ return $str;
+}
+
+
+#
+# ->_stringify_polar
+#
+# Stringify as a polar representation '[r,t]'.
+#
+sub _stringify_polar {
+ my $z = shift;
+ my ($r, $t) = @{$z->_polar};
+ my $theta;
+
+ my %format = $z->display_format;
+ my $format = $format{format};
+
+ if ($t =~ /^NaN[QS]?$/i || $t =~ /^-?\Q$Inf\E$/oi) {
+ $theta = $t;
+ } elsif ($t == pi) {
+ $theta = "pi";
+ } elsif ($r == 0 || $t == 0) {
+ $theta = defined $format ? sprintf($format, $t) : $t;
+ }
+
+ return "[$r,$theta]" if defined $theta;
+
+ #
+ # Try to identify pi/n and friends.
+ #
+
+ $t -= int(CORE::abs($t) / pi2) * pi2;
+
+ if ($format{polar_pretty_print} && $t) {
+ my ($a, $b);
+ for $a (2..9) {
+ $b = $t * $a / pi;
+ if ($b =~ /^-?\d+$/) {
+ $b = $b < 0 ? "-" : "" if CORE::abs($b) == 1;
+ $theta = "${b}pi/$a";
+ last;
+ }
+ }
+ }
+
+ if (defined $format) {
+ $r = sprintf($format, $r);
+ $theta = sprintf($format, $theta) unless defined $theta;
+ } else {
+ $theta = $t unless defined $theta;
+ }
+
+ return "[$r,$theta]";
+}
+
+sub Inf {
+ return $Inf;
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+Math::Complex - complex numbers and associated mathematical functions
+
+=head1 SYNOPSIS
+
+ use Math::Complex;
+
+ $z = Math::Complex->make(5, 6);
+ $t = 4 - 3*i + $z;
+ $j = cplxe(1, 2*pi/3);
+
+=head1 DESCRIPTION
+
+This package lets you create and manipulate complex numbers. By default,
+I<Perl> limits itself to real numbers, but an extra C<use> statement brings
+full complex support, along with a full set of mathematical functions
+typically associated with and/or extended to complex numbers.
+
+If you wonder what complex numbers are, they were invented to be able to solve
+the following equation:
+
+ x*x = -1
+
+and by definition, the solution is noted I<i> (engineers use I<j> instead since
+I<i> usually denotes an intensity, but the name does not matter). The number
+I<i> is a pure I<imaginary> number.
+
+The arithmetics with pure imaginary numbers works just like you would expect
+it with real numbers... you just have to remember that
+
+ i*i = -1
+
+so you have:
+
+ 5i + 7i = i * (5 + 7) = 12i
+ 4i - 3i = i * (4 - 3) = i
+ 4i * 2i = -8
+ 6i / 2i = 3
+ 1 / i = -i
+
+Complex numbers are numbers that have both a real part and an imaginary
+part, and are usually noted:
+
+ a + bi
+
+where C<a> is the I<real> part and C<b> is the I<imaginary> part. The
+arithmetic with complex numbers is straightforward. You have to
+keep track of the real and the imaginary parts, but otherwise the
+rules used for real numbers just apply:
+
+ (4 + 3i) + (5 - 2i) = (4 + 5) + i(3 - 2) = 9 + i
+ (2 + i) * (4 - i) = 2*4 + 4i -2i -i*i = 8 + 2i + 1 = 9 + 2i
+
+A graphical representation of complex numbers is possible in a plane
+(also called the I<complex plane>, but it's really a 2D plane).
+The number
+
+ z = a + bi
+
+is the point whose coordinates are (a, b). Actually, it would
+be the vector originating from (0, 0) to (a, b). It follows that the addition
+of two complex numbers is a vectorial addition.
+
+Since there is a bijection between a point in the 2D plane and a complex
+number (i.e. the mapping is unique and reciprocal), a complex number
+can also be uniquely identified with polar coordinates:
+
+ [rho, theta]
+
+where C<rho> is the distance to the origin, and C<theta> the angle between
+the vector and the I<x> axis. There is a notation for this using the
+exponential form, which is:
+
+ rho * exp(i * theta)
+
+where I<i> is the famous imaginary number introduced above. Conversion
+between this form and the cartesian form C<a + bi> is immediate:
+
+ a = rho * cos(theta)
+ b = rho * sin(theta)
+
+which is also expressed by this formula:
+
+ z = rho * exp(i * theta) = rho * (cos theta + i * sin theta)
+
+In other words, it's the projection of the vector onto the I<x> and I<y>
+axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta>
+the I<argument> of the complex number. The I<norm> of C<z> is
+marked here as C<abs(z)>.
+
+The polar notation (also known as the trigonometric representation) is
+much more handy for performing multiplications and divisions of
+complex numbers, whilst the cartesian notation is better suited for
+additions and subtractions. Real numbers are on the I<x> axis, and
+therefore I<y> or I<theta> is zero or I<pi>.
+
+All the common operations that can be performed on a real number have
+been defined to work on complex numbers as well, and are merely
+I<extensions> of the operations defined on real numbers. This means
+they keep their natural meaning when there is no imaginary part, provided
+the number is within their definition set.
+
+For instance, the C<sqrt> routine which computes the square root of
+its argument is only defined for non-negative real numbers and yields a
+non-negative real number (it is an application from B<R+> to B<R+>).
+If we allow it to return a complex number, then it can be extended to
+negative real numbers to become an application from B<R> to B<C> (the
+set of complex numbers):
+
+ sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i
+
+It can also be extended to be an application from B<C> to B<C>,
+whilst its restriction to B<R> behaves as defined above by using
+the following definition:
+
+ sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2)
+
+Indeed, a negative real number can be noted C<[x,pi]> (the modulus
+I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative
+number) and the above definition states that
+
+ sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i
+
+which is exactly what we had defined for negative real numbers above.
+The C<sqrt> returns only one of the solutions: if you want the both,
+use the C<root> function.
+
+All the common mathematical functions defined on real numbers that
+are extended to complex numbers share that same property of working
+I<as usual> when the imaginary part is zero (otherwise, it would not
+be called an extension, would it?).
+
+A I<new> operation possible on a complex number that is
+the identity for real numbers is called the I<conjugate>, and is noted
+with a horizontal bar above the number, or C<~z> here.
+
+ z = a + bi
+ ~z = a - bi
+
+Simple... Now look:
+
+ z * ~z = (a + bi) * (a - bi) = a*a + b*b
+
+We saw that the norm of C<z> was noted C<abs(z)> and was defined as the
+distance to the origin, also known as:
+
+ rho = abs(z) = sqrt(a*a + b*b)
+
+so
+
+ z * ~z = abs(z) ** 2
+
+If z is a pure real number (i.e. C<b == 0>), then the above yields:
+
+ a * a = abs(a) ** 2
+
+which is true (C<abs> has the regular meaning for real number, i.e. stands
+for the absolute value). This example explains why the norm of C<z> is
+noted C<abs(z)>: it extends the C<abs> function to complex numbers, yet
+is the regular C<abs> we know when the complex number actually has no
+imaginary part... This justifies I<a posteriori> our use of the C<abs>
+notation for the norm.
+
+=head1 OPERATIONS
+
+Given the following notations:
+
+ z1 = a + bi = r1 * exp(i * t1)
+ z2 = c + di = r2 * exp(i * t2)
+ z = <any complex or real number>
+
+the following (overloaded) operations are supported on complex numbers:
+
+ z1 + z2 = (a + c) + i(b + d)
+ z1 - z2 = (a - c) + i(b - d)
+ z1 * z2 = (r1 * r2) * exp(i * (t1 + t2))
+ z1 / z2 = (r1 / r2) * exp(i * (t1 - t2))
+ z1 ** z2 = exp(z2 * log z1)
+ ~z = a - bi
+ abs(z) = r1 = sqrt(a*a + b*b)
+ sqrt(z) = sqrt(r1) * exp(i * t/2)
+ exp(z) = exp(a) * exp(i * b)
+ log(z) = log(r1) + i*t
+ sin(z) = 1/2i (exp(i * z1) - exp(-i * z))
+ cos(z) = 1/2 (exp(i * z1) + exp(-i * z))
+ atan2(y, x) = atan(y / x) # Minding the right quadrant, note the order.
+
+The definition used for complex arguments of atan2() is
+
+ -i log((x + iy)/sqrt(x*x+y*y))
+
+Note that atan2(0, 0) is not well-defined.
+
+The following extra operations are supported on both real and complex
+numbers:
+
+ Re(z) = a
+ Im(z) = b
+ arg(z) = t
+ abs(z) = r
+
+ cbrt(z) = z ** (1/3)
+ log10(z) = log(z) / log(10)
+ logn(z, n) = log(z) / log(n)
+
+ tan(z) = sin(z) / cos(z)
+
+ csc(z) = 1 / sin(z)
+ sec(z) = 1 / cos(z)
+ cot(z) = 1 / tan(z)
+
+ asin(z) = -i * log(i*z + sqrt(1-z*z))
+ acos(z) = -i * log(z + i*sqrt(1-z*z))
+ atan(z) = i/2 * log((i+z) / (i-z))
+
+ acsc(z) = asin(1 / z)
+ asec(z) = acos(1 / z)
+ acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i))
+
+ sinh(z) = 1/2 (exp(z) - exp(-z))
+ cosh(z) = 1/2 (exp(z) + exp(-z))
+ tanh(z) = sinh(z) / cosh(z) = (exp(z) - exp(-z)) / (exp(z) + exp(-z))
+
+ csch(z) = 1 / sinh(z)
+ sech(z) = 1 / cosh(z)
+ coth(z) = 1 / tanh(z)
+
+ asinh(z) = log(z + sqrt(z*z+1))
+ acosh(z) = log(z + sqrt(z*z-1))
+ atanh(z) = 1/2 * log((1+z) / (1-z))
+
+ acsch(z) = asinh(1 / z)
+ asech(z) = acosh(1 / z)
+ acoth(z) = atanh(1 / z) = 1/2 * log((1+z) / (z-1))
+
+I<arg>, I<abs>, I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>,
+I<coth>, I<acosech>, I<acotanh>, have aliases I<rho>, I<theta>, I<ln>,
+I<cosec>, I<cotan>, I<acosec>, I<acotan>, I<cosech>, I<cotanh>,
+I<acosech>, I<acotanh>, respectively. C<Re>, C<Im>, C<arg>, C<abs>,
+C<rho>, and C<theta> can be used also as mutators. The C<cbrt>
+returns only one of the solutions: if you want all three, use the
+C<root> function.
+
+The I<root> function is available to compute all the I<n>
+roots of some complex, where I<n> is a strictly positive integer.
+There are exactly I<n> such roots, returned as a list. Getting the
+number mathematicians call C<j> such that:
+
+ 1 + j + j*j = 0;
+
+is a simple matter of writing:
+
+ $j = ((root(1, 3))[1];
+
+The I<k>th root for C<z = [r,t]> is given by:
+
+ (root(z, n))[k] = r**(1/n) * exp(i * (t + 2*k*pi)/n)
+
+You can return the I<k>th root directly by C<root(z, n, k)>,
+indexing starting from I<zero> and ending at I<n - 1>.
+
+The I<spaceship> numeric comparison operator, E<lt>=E<gt>, is also
+defined. In order to ensure its restriction to real numbers is conform
+to what you would expect, the comparison is run on the real part of
+the complex number first, and imaginary parts are compared only when
+the real parts match.
+
+=head1 CREATION
+
+To create a complex number, use either:
+
+ $z = Math::Complex->make(3, 4);
+ $z = cplx(3, 4);
+
+if you know the cartesian form of the number, or
+
+ $z = 3 + 4*i;
+
+if you like. To create a number using the polar form, use either:
+
+ $z = Math::Complex->emake(5, pi/3);
+ $x = cplxe(5, pi/3);
+
+instead. The first argument is the modulus, the second is the angle
+(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a
+notation for complex numbers in the polar form).
+
+It is possible to write:
+
+ $x = cplxe(-3, pi/4);
+
+but that will be silently converted into C<[3,-3pi/4]>, since the
+modulus must be non-negative (it represents the distance to the origin
+in the complex plane).
+
+It is also possible to have a complex number as either argument of the
+C<make>, C<emake>, C<cplx>, and C<cplxe>: the appropriate component of
+the argument will be used.
+
+ $z1 = cplx(-2, 1);
+ $z2 = cplx($z1, 4);
+
+The C<new>, C<make>, C<emake>, C<cplx>, and C<cplxe> will also
+understand a single (string) argument of the forms
+
+ 2-3i
+ -3i
+ [2,3]
+ [2,-3pi/4]
+ [2]
+
+in which case the appropriate cartesian and exponential components
+will be parsed from the string and used to create new complex numbers.
+The imaginary component and the theta, respectively, will default to zero.
+
+The C<new>, C<make>, C<emake>, C<cplx>, and C<cplxe> will also
+understand the case of no arguments: this means plain zero or (0, 0).
+
+=head1 DISPLAYING
+
+When printed, a complex number is usually shown under its cartesian
+style I<a+bi>, but there are legitimate cases where the polar style
+I<[r,t]> is more appropriate. The process of converting the complex
+number into a string that can be displayed is known as I<stringification>.
+
+By calling the class method C<Math::Complex::display_format> and
+supplying either C<"polar"> or C<"cartesian"> as an argument, you
+override the default display style, which is C<"cartesian">. Not
+supplying any argument returns the current settings.
+
+This default can be overridden on a per-number basis by calling the
+C<display_format> method instead. As before, not supplying any argument
+returns the current display style for this number. Otherwise whatever you
+specify will be the new display style for I<this> particular number.
+
+For instance:
+
+ use Math::Complex;
+
+ Math::Complex::display_format('polar');
+ $j = (root(1, 3))[1];
+ print "j = $j\n"; # Prints "j = [1,2pi/3]"
+ $j->display_format('cartesian');
+ print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i"
+
+The polar style attempts to emphasize arguments like I<k*pi/n>
+(where I<n> is a positive integer and I<k> an integer within [-9, +9]),
+this is called I<polar pretty-printing>.
+
+For the reverse of stringifying, see the C<make> and C<emake>.
+
+=head2 CHANGED IN PERL 5.6
+
+The C<display_format> class method and the corresponding
+C<display_format> object method can now be called using
+a parameter hash instead of just a one parameter.
+
+The old display format style, which can have values C<"cartesian"> or
+C<"polar">, can be changed using the C<"style"> parameter.
+
+ $j->display_format(style => "polar");
+
+The one parameter calling convention also still works.
+
+ $j->display_format("polar");
+
+There are two new display parameters.
+
+The first one is C<"format">, which is a sprintf()-style format string
+to be used for both numeric parts of the complex number(s). The is
+somewhat system-dependent but most often it corresponds to C<"%.15g">.
+You can revert to the default by setting the C<format> to C<undef>.
+
+ # the $j from the above example
+
+ $j->display_format('format' => '%.5f');
+ print "j = $j\n"; # Prints "j = -0.50000+0.86603i"
+ $j->display_format('format' => undef);
+ print "j = $j\n"; # Prints "j = -0.5+0.86603i"
+
+Notice that this affects also the return values of the
+C<display_format> methods: in list context the whole parameter hash
+will be returned, as opposed to only the style parameter value.
+This is a potential incompatibility with earlier versions if you
+have been calling the C<display_format> method in list context.
+
+The second new display parameter is C<"polar_pretty_print">, which can
+be set to true or false, the default being true. See the previous
+section for what this means.
+
+=head1 USAGE
+
+Thanks to overloading, the handling of arithmetics with complex numbers
+is simple and almost transparent.
+
+Here are some examples:
+
+ use Math::Complex;
+
+ $j = cplxe(1, 2*pi/3); # $j ** 3 == 1
+ print "j = $j, j**3 = ", $j ** 3, "\n";
+ print "1 + j + j**2 = ", 1 + $j + $j**2, "\n";
+
+ $z = -16 + 0*i; # Force it to be a complex
+ print "sqrt($z) = ", sqrt($z), "\n";
+
+ $k = exp(i * 2*pi/3);
+ print "$j - $k = ", $j - $k, "\n";
+
+ $z->Re(3); # Re, Im, arg, abs,
+ $j->arg(2); # (the last two aka rho, theta)
+ # can be used also as mutators.
+
+=head1 CONSTANTS
+
+=head2 PI
+
+The constant C<pi> and some handy multiples of it (pi2, pi4,
+and pip2 (pi/2) and pip4 (pi/4)) are also available if separately
+exported:
+
+ use Math::Complex ':pi';
+ $third_of_circle = pi2 / 3;
+
+=head2 Inf
+
+The floating point infinity can be exported as a subroutine Inf():
+
+ use Math::Complex qw(Inf sinh);
+ my $AlsoInf = Inf() + 42;
+ my $AnotherInf = sinh(1e42);
+ print "$AlsoInf is $AnotherInf\n" if $AlsoInf == $AnotherInf;
+
+Note that the stringified form of infinity varies between platforms:
+it can be for example any of
+
+ inf
+ infinity
+ INF
+ 1.#INF
+
+or it can be something else.
+
+Also note that in some platforms trying to use the infinity in
+arithmetic operations may result in Perl crashing because using
+an infinity causes SIGFPE or its moral equivalent to be sent.
+The way to ignore this is
+
+ local $SIG{FPE} = sub { };
+
+=head1 ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO
+
+The division (/) and the following functions
+
+ log ln log10 logn
+ tan sec csc cot
+ atan asec acsc acot
+ tanh sech csch coth
+ atanh asech acsch acoth
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the
+logarithmic functions and the C<atanh>, C<acoth>, the argument cannot
+be C<1> (one). For the C<atanh>, C<acoth>, the argument cannot be
+C<-1> (minus one). For the C<atan>, C<acot>, the argument cannot be
+C<i> (the imaginary unit). For the C<atan>, C<acoth>, the argument
+cannot be C<-i> (the negative imaginary unit). For the C<tan>,
+C<sec>, C<tanh>, the argument cannot be I<pi/2 + k * pi>, where I<k>
+is any integer. atan2(0, 0) is undefined, and if the complex arguments
+are used for atan2(), a division by zero will happen if z1**2+z2**2 == 0.
+
+Note that because we are operating on approximations of real numbers,
+these errors can happen when merely `too close' to the singularities
+listed above.
+
+=head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS
+
+The C<make> and C<emake> accept both real and complex arguments.
+When they cannot recognize the arguments they will die with error
+messages like the following
+
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::emake: Cannot take rho of ...
+ Math::Complex::emake: Cannot take theta of ...
+
+=head1 BUGS
+
+Saying C<use Math::Complex;> exports many mathematical routines in the
+caller environment and even overrides some (C<sqrt>, C<log>, C<atan2>).
+This is construed as a feature by the Authors, actually... ;-)
+
+All routines expect to be given real or complex numbers. Don't attempt to
+use BigFloat, since Perl has currently no rule to disambiguate a '+'
+operation (for instance) between two overloaded entities.
+
+In Cray UNICOS there is some strange numerical instability that results
+in root(), cos(), sin(), cosh(), sinh(), losing accuracy fast. Beware.
+The bug may be in UNICOS math libs, in UNICOS C compiler, in Math::Complex.
+Whatever it is, it does not manifest itself anywhere else where Perl runs.
+
+=head1 SEE ALSO
+
+L<Math::Trig>
+
+=head1 AUTHORS
+
+Daniel S. Lewart <F<lewart!at!uiuc.edu>>
+Jarkko Hietaniemi <F<jhi!at!iki.fi>>
+Raphael Manfredi <F<Raphael_Manfredi!at!pobox.com>>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
+
+# eof
diff --git a/Master/tlpkg/tlperl/lib/Math/Trig.pm b/Master/tlpkg/tlperl/lib/Math/Trig.pm
new file mode 100644
index 00000000000..b7767bebccb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Math/Trig.pm
@@ -0,0 +1,768 @@
+#
+# Trigonometric functions, mostly inherited from Math::Complex.
+# -- Jarkko Hietaniemi, since April 1997
+# -- Raphael Manfredi, September 1996 (indirectly: because of Math::Complex)
+#
+
+require Exporter;
+package Math::Trig;
+
+use 5.005;
+use strict;
+
+use Math::Complex 1.56;
+use Math::Complex qw(:trig :pi);
+
+use vars qw($VERSION $PACKAGE @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+@ISA = qw(Exporter);
+
+$VERSION = 1.20;
+
+my @angcnv = qw(rad2deg rad2grad
+ deg2rad deg2grad
+ grad2rad grad2deg);
+
+my @areal = qw(asin_real acos_real);
+
+@EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}},
+ @angcnv, @areal);
+
+my @rdlcnv = qw(cartesian_to_cylindrical
+ cartesian_to_spherical
+ cylindrical_to_cartesian
+ cylindrical_to_spherical
+ spherical_to_cartesian
+ spherical_to_cylindrical);
+
+my @greatcircle = qw(
+ great_circle_distance
+ great_circle_direction
+ great_circle_bearing
+ great_circle_waypoint
+ great_circle_midpoint
+ great_circle_destination
+ );
+
+my @pi = qw(pi pi2 pi4 pip2 pip4);
+
+@EXPORT_OK = (@rdlcnv, @greatcircle, @pi, 'Inf');
+
+# See e.g. the following pages:
+# http://www.movable-type.co.uk/scripts/LatLong.html
+# http://williams.best.vwh.net/avform.htm
+
+%EXPORT_TAGS = ('radial' => [ @rdlcnv ],
+ 'great_circle' => [ @greatcircle ],
+ 'pi' => [ @pi ]);
+
+sub _DR () { pi2/360 }
+sub _RD () { 360/pi2 }
+sub _DG () { 400/360 }
+sub _GD () { 360/400 }
+sub _RG () { 400/pi2 }
+sub _GR () { pi2/400 }
+
+#
+# Truncating remainder.
+#
+
+sub _remt ($$) {
+ # Oh yes, POSIX::fmod() would be faster. Possibly. If it is available.
+ $_[0] - $_[1] * int($_[0] / $_[1]);
+}
+
+#
+# Angle conversions.
+#
+
+sub rad2rad($) { _remt($_[0], pi2) }
+
+sub deg2deg($) { _remt($_[0], 360) }
+
+sub grad2grad($) { _remt($_[0], 400) }
+
+sub rad2deg ($;$) { my $d = _RD * $_[0]; $_[1] ? $d : deg2deg($d) }
+
+sub deg2rad ($;$) { my $d = _DR * $_[0]; $_[1] ? $d : rad2rad($d) }
+
+sub grad2deg ($;$) { my $d = _GD * $_[0]; $_[1] ? $d : deg2deg($d) }
+
+sub deg2grad ($;$) { my $d = _DG * $_[0]; $_[1] ? $d : grad2grad($d) }
+
+sub rad2grad ($;$) { my $d = _RG * $_[0]; $_[1] ? $d : grad2grad($d) }
+
+sub grad2rad ($;$) { my $d = _GR * $_[0]; $_[1] ? $d : rad2rad($d) }
+
+#
+# acos and asin functions which always return a real number
+#
+
+sub acos_real {
+ return 0 if $_[0] >= 1;
+ return pi if $_[0] <= -1;
+ return acos($_[0]);
+}
+
+sub asin_real {
+ return &pip2 if $_[0] >= 1;
+ return -&pip2 if $_[0] <= -1;
+ return asin($_[0]);
+}
+
+sub cartesian_to_spherical {
+ my ( $x, $y, $z ) = @_;
+
+ my $rho = sqrt( $x * $x + $y * $y + $z * $z );
+
+ return ( $rho,
+ atan2( $y, $x ),
+ $rho ? acos_real( $z / $rho ) : 0 );
+}
+
+sub spherical_to_cartesian {
+ my ( $rho, $theta, $phi ) = @_;
+
+ return ( $rho * cos( $theta ) * sin( $phi ),
+ $rho * sin( $theta ) * sin( $phi ),
+ $rho * cos( $phi ) );
+}
+
+sub spherical_to_cylindrical {
+ my ( $x, $y, $z ) = spherical_to_cartesian( @_ );
+
+ return ( sqrt( $x * $x + $y * $y ), $_[1], $z );
+}
+
+sub cartesian_to_cylindrical {
+ my ( $x, $y, $z ) = @_;
+
+ return ( sqrt( $x * $x + $y * $y ), atan2( $y, $x ), $z );
+}
+
+sub cylindrical_to_cartesian {
+ my ( $rho, $theta, $z ) = @_;
+
+ return ( $rho * cos( $theta ), $rho * sin( $theta ), $z );
+}
+
+sub cylindrical_to_spherical {
+ return ( cartesian_to_spherical( cylindrical_to_cartesian( @_ ) ) );
+}
+
+sub great_circle_distance {
+ my ( $theta0, $phi0, $theta1, $phi1, $rho ) = @_;
+
+ $rho = 1 unless defined $rho; # Default to the unit sphere.
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ return $rho *
+ acos_real( cos( $lat0 ) * cos( $lat1 ) * cos( $theta0 - $theta1 ) +
+ sin( $lat0 ) * sin( $lat1 ) );
+}
+
+sub great_circle_direction {
+ my ( $theta0, $phi0, $theta1, $phi1 ) = @_;
+
+ my $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1);
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ my $direction =
+ acos_real((sin($lat1) - sin($lat0) * cos($distance)) /
+ (cos($lat0) * sin($distance)));
+
+ $direction = pi2 - $direction
+ if sin($theta1 - $theta0) < 0;
+
+ return rad2rad($direction);
+}
+
+*great_circle_bearing = \&great_circle_direction;
+
+sub great_circle_waypoint {
+ my ( $theta0, $phi0, $theta1, $phi1, $point ) = @_;
+
+ $point = 0.5 unless defined $point;
+
+ my $d = great_circle_distance( $theta0, $phi0, $theta1, $phi1 );
+
+ return undef if $d == pi;
+
+ my $sd = sin($d);
+
+ return ($theta0, $phi0) if $sd == 0;
+
+ my $A = sin((1 - $point) * $d) / $sd;
+ my $B = sin( $point * $d) / $sd;
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ my $x = $A * cos($lat0) * cos($theta0) + $B * cos($lat1) * cos($theta1);
+ my $y = $A * cos($lat0) * sin($theta0) + $B * cos($lat1) * sin($theta1);
+ my $z = $A * sin($lat0) + $B * sin($lat1);
+
+ my $theta = atan2($y, $x);
+ my $phi = acos_real($z);
+
+ return ($theta, $phi);
+}
+
+sub great_circle_midpoint {
+ great_circle_waypoint(@_[0..3], 0.5);
+}
+
+sub great_circle_destination {
+ my ( $theta0, $phi0, $dir0, $dst ) = @_;
+
+ my $lat0 = pip2 - $phi0;
+
+ my $phi1 = asin_real(sin($lat0)*cos($dst) +
+ cos($lat0)*sin($dst)*cos($dir0));
+
+ my $theta1 = $theta0 + atan2(sin($dir0)*sin($dst)*cos($lat0),
+ cos($dst)-sin($lat0)*sin($phi1));
+
+ my $dir1 = great_circle_bearing($theta1, $phi1, $theta0, $phi0) + pi;
+
+ $dir1 -= pi2 if $dir1 > pi2;
+
+ return ($theta1, $phi1, $dir1);
+}
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+Math::Trig - trigonometric functions
+
+=head1 SYNOPSIS
+
+ use Math::Trig;
+
+ $x = tan(0.9);
+ $y = acos(3.7);
+ $z = asin(2.4);
+
+ $halfpi = pi/2;
+
+ $rad = deg2rad(120);
+
+ # Import constants pi2, pip2, pip4 (2*pi, pi/2, pi/4).
+ use Math::Trig ':pi';
+
+ # Import the conversions between cartesian/spherical/cylindrical.
+ use Math::Trig ':radial';
+
+ # Import the great circle formulas.
+ use Math::Trig ':great_circle';
+
+=head1 DESCRIPTION
+
+C<Math::Trig> defines many trigonometric functions not defined by the
+core Perl which defines only the C<sin()> and C<cos()>. The constant
+B<pi> is also defined as are a few convenience functions for angle
+conversions, and I<great circle formulas> for spherical movement.
+
+=head1 TRIGONOMETRIC FUNCTIONS
+
+The tangent
+
+=over 4
+
+=item B<tan>
+
+=back
+
+The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot
+are aliases)
+
+B<csc>, B<cosec>, B<sec>, B<sec>, B<cot>, B<cotan>
+
+The arcus (also known as the inverse) functions of the sine, cosine,
+and tangent
+
+B<asin>, B<acos>, B<atan>
+
+The principal value of the arc tangent of y/x
+
+B<atan2>(y, x)
+
+The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc
+and acotan/acot are aliases). Note that atan2(0, 0) is not well-defined.
+
+B<acsc>, B<acosec>, B<asec>, B<acot>, B<acotan>
+
+The hyperbolic sine, cosine, and tangent
+
+B<sinh>, B<cosh>, B<tanh>
+
+The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch
+and cotanh/coth are aliases)
+
+B<csch>, B<cosech>, B<sech>, B<coth>, B<cotanh>
+
+The area (also known as the inverse) functions of the hyperbolic
+sine, cosine, and tangent
+
+B<asinh>, B<acosh>, B<atanh>
+
+The area cofunctions of the hyperbolic sine, cosine, and tangent
+(acsch/acosech and acoth/acotanh are aliases)
+
+B<acsch>, B<acosech>, B<asech>, B<acoth>, B<acotanh>
+
+The trigonometric constant B<pi> and some of handy multiples
+of it are also defined.
+
+B<pi, pi2, pi4, pip2, pip4>
+
+=head2 ERRORS DUE TO DIVISION BY ZERO
+
+The following functions
+
+ acoth
+ acsc
+ acsch
+ asec
+ asech
+ atanh
+ cot
+ coth
+ csc
+ csch
+ sec
+ sech
+ tan
+ tanh
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the
+C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the
+C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the
+C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k *
+pi>, where I<k> is any integer.
+
+Note that atan2(0, 0) is not well-defined.
+
+=head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS
+
+Please note that some of the trigonometric functions can break out
+from the B<real axis> into the B<complex plane>. For example
+C<asin(2)> has no definition for plain real numbers but it has
+definition for complex numbers.
+
+In Perl terms this means that supplying the usual Perl numbers (also
+known as scalars, please see L<perldata>) as input for the
+trigonometric functions might produce as output results that no more
+are simple real numbers: instead they are complex numbers.
+
+The C<Math::Trig> handles this by using the C<Math::Complex> package
+which knows how to handle complex numbers, please see L<Math::Complex>
+for more information. In practice you need not to worry about getting
+complex numbers as results because the C<Math::Complex> takes care of
+details like for example how to display complex numbers. For example:
+
+ print asin(2), "\n";
+
+should produce something like this (take or leave few last decimals):
+
+ 1.5707963267949-1.31695789692482i
+
+That is, a complex number with the real part of approximately C<1.571>
+and the imaginary part of approximately C<-1.317>.
+
+=head1 PLANE ANGLE CONVERSIONS
+
+(Plane, 2-dimensional) angles may be converted with the following functions.
+
+=over
+
+=item deg2rad
+
+ $radians = deg2rad($degrees);
+
+=item grad2rad
+
+ $radians = grad2rad($gradians);
+
+=item rad2deg
+
+ $degrees = rad2deg($radians);
+
+=item grad2deg
+
+ $degrees = grad2deg($gradians);
+
+=item deg2grad
+
+ $gradians = deg2grad($degrees);
+
+=item rad2grad
+
+ $gradians = rad2grad($radians);
+
+=back
+
+The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians.
+The result is by default wrapped to be inside the [0, {2pi,360,400}[ circle.
+If you don't want this, supply a true second argument:
+
+ $zillions_of_radians = deg2rad($zillions_of_degrees, 1);
+ $negative_degrees = rad2deg($negative_radians, 1);
+
+You can also do the wrapping explicitly by rad2rad(), deg2deg(), and
+grad2grad().
+
+=over 4
+
+=item rad2rad
+
+ $radians_wrapped_by_2pi = rad2rad($radians);
+
+=item deg2deg
+
+ $degrees_wrapped_by_360 = deg2deg($degrees);
+
+=item grad2grad
+
+ $gradians_wrapped_by_400 = grad2grad($gradians);
+
+=back
+
+=head1 RADIAL COORDINATE CONVERSIONS
+
+B<Radial coordinate systems> are the B<spherical> and the B<cylindrical>
+systems, explained shortly in more detail.
+
+You can import radial coordinate conversion functions by using the
+C<:radial> tag:
+
+ use Math::Trig ':radial';
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+B<All angles are in radians>.
+
+=head2 COORDINATE SYSTEMS
+
+B<Cartesian> coordinates are the usual rectangular I<(x, y, z)>-coordinates.
+
+Spherical coordinates, I<(rho, theta, pi)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a sphere surface. The radius of the sphere is B<rho>, also
+known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The angle from the I<z>-axis is B<phi>, also known as the
+I<polar> coordinate. The North Pole is therefore I<0, 0, rho>, and
+the Gulf of Guinea (think of the missing big chunk of Africa) I<0,
+pi/2, rho>. In geographical terms I<phi> is latitude (northward
+positive, southward negative) and I<theta> is longitude (eastward
+positive, westward negative).
+
+B<BEWARE>: some texts define I<theta> and I<phi> the other way round,
+some texts define the I<phi> to start from the horizontal plane, some
+texts use I<r> in place of I<rho>.
+
+Cylindrical coordinates, I<(rho, theta, z)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a cylinder surface. The radius of the cylinder is B<rho>,
+also known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The third coordinate is the I<z>, pointing up from the
+B<theta>-plane.
+
+=head2 3-D ANGLE CONVERSIONS
+
+Conversions to and from spherical and cylindrical coordinates are
+available. Please notice that the conversions are not necessarily
+reversible because of the equalities like I<pi> angles being equal to
+I<-pi> angles.
+
+=over 4
+
+=item cartesian_to_cylindrical
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+
+=item cartesian_to_spherical
+
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+
+=item cylindrical_to_cartesian
+
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+
+=item cylindrical_to_spherical
+
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+
+Notice that when C<$z> is not 0 C<$rho_s> is not equal to C<$rho_c>.
+
+=item spherical_to_cartesian
+
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+
+=item spherical_to_cylindrical
+
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+Notice that when C<$z> is not 0 C<$rho_c> is not equal to C<$rho_s>.
+
+=back
+
+=head1 GREAT CIRCLE DISTANCES AND DIRECTIONS
+
+A great circle is section of a circle that contains the circle
+diameter: the shortest distance between two (non-antipodal) points on
+the spherical surface goes along the great circle connecting those two
+points.
+
+=head2 great_circle_distance
+
+You can compute spherical distances, called B<great circle distances>,
+by importing the great_circle_distance() function:
+
+ use Math::Trig 'great_circle_distance';
+
+ $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]);
+
+The I<great circle distance> is the shortest distance between two
+points on a sphere. The distance is in C<$rho> units. The C<$rho> is
+optional, it defaults to 1 (the unit sphere), therefore the distance
+defaults to radians.
+
+If you think geographically the I<theta> are longitudes: zero at the
+Greenwhich meridian, eastward positive, westward negative -- and the
+I<phi> are latitudes: zero at the North Pole, northward positive,
+southward negative. B<NOTE>: this formula thinks in mathematics, not
+geographically: the I<phi> zero is at the North Pole, not at the
+Equator on the west coast of Africa (Bay of Guinea). You need to
+subtract your geographical coordinates from I<pi/2> (also known as 90
+degrees).
+
+ $distance = great_circle_distance($lon0, pi/2 - $lat0,
+ $lon1, pi/2 - $lat1, $rho);
+
+=head2 great_circle_direction
+
+The direction you must follow the great circle (also known as I<bearing>)
+can be computed by the great_circle_direction() function:
+
+ use Math::Trig 'great_circle_direction';
+
+ $direction = great_circle_direction($theta0, $phi0, $theta1, $phi1);
+
+=head2 great_circle_bearing
+
+Alias 'great_circle_bearing' for 'great_circle_direction' is also available.
+
+ use Math::Trig 'great_circle_bearing';
+
+ $direction = great_circle_bearing($theta0, $phi0, $theta1, $phi1);
+
+The result of great_circle_direction is in radians, zero indicating
+straight north, pi or -pi straight south, pi/2 straight west, and
+-pi/2 straight east.
+
+=head2 great_circle_destination
+
+You can inversely compute the destination if you know the
+starting point, direction, and distance:
+
+ use Math::Trig 'great_circle_destination';
+
+ # $diro is the original direction,
+ # for example from great_circle_bearing().
+ # $distance is the angular distance in radians,
+ # for example from great_circle_distance().
+ # $thetad and $phid are the destination coordinates,
+ # $dird is the final direction at the destination.
+
+ ($thetad, $phid, $dird) =
+ great_circle_destination($theta, $phi, $diro, $distance);
+
+or the midpoint if you know the end points:
+
+=head2 great_circle_midpoint
+
+ use Math::Trig 'great_circle_midpoint';
+
+ ($thetam, $phim) =
+ great_circle_midpoint($theta0, $phi0, $theta1, $phi1);
+
+The great_circle_midpoint() is just a special case of
+
+=head2 great_circle_waypoint
+
+ use Math::Trig 'great_circle_waypoint';
+
+ ($thetai, $phii) =
+ great_circle_waypoint($theta0, $phi0, $theta1, $phi1, $way);
+
+Where the $way is a value from zero ($theta0, $phi0) to one ($theta1,
+$phi1). Note that antipodal points (where their distance is I<pi>
+radians) do not have waypoints between them (they would have an an
+"equator" between them), and therefore C<undef> is returned for
+antipodal points. If the points are the same and the distance
+therefore zero and all waypoints therefore identical, the first point
+(either point) is returned.
+
+The thetas, phis, direction, and distance in the above are all in radians.
+
+You can import all the great circle formulas by
+
+ use Math::Trig ':great_circle';
+
+Notice that the resulting directions might be somewhat surprising if
+you are looking at a flat worldmap: in such map projections the great
+circles quite often do not look like the shortest routes -- but for
+example the shortest possible routes from Europe or North America to
+Asia do often cross the polar regions. (The common Mercator projection
+does B<not> show great circles as straight lines: straight lines in the
+Mercator projection are lines of constant bearing.)
+
+=head1 EXAMPLES
+
+To calculate the distance between London (51.3N 0.5W) and Tokyo
+(35.7N 139.8E) in kilometers:
+
+ use Math::Trig qw(great_circle_distance deg2rad);
+
+ # Notice the 90 - latitude: phi zero is at the North Pole.
+ sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }
+ my @L = NESW( -0.5, 51.3);
+ my @T = NESW(139.8, 35.7);
+ my $km = great_circle_distance(@L, @T, 6378); # About 9600 km.
+
+The direction you would have to go from London to Tokyo (in radians,
+straight north being zero, straight east being pi/2).
+
+ use Math::Trig qw(great_circle_direction);
+
+ my $rad = great_circle_direction(@L, @T); # About 0.547 or 0.174 pi.
+
+The midpoint between London and Tokyo being
+
+ use Math::Trig qw(great_circle_midpoint);
+
+ my @M = great_circle_midpoint(@L, @T);
+
+or about 69 N 89 E, in the frozen wastes of Siberia.
+
+B<NOTE>: you B<cannot> get from A to B like this:
+
+ Dist = great_circle_distance(A, B)
+ Dir = great_circle_direction(A, B)
+ C = great_circle_destination(A, Dist, Dir)
+
+and expect C to be B, because the bearing constantly changes when
+going from A to B (except in some special case like the meridians or
+the circles of latitudes) and in great_circle_destination() one gives
+a B<constant> bearing to follow.
+
+=head2 CAVEAT FOR GREAT CIRCLE FORMULAS
+
+The answers may be off by few percentages because of the irregular
+(slightly aspherical) form of the Earth. The errors are at worst
+about 0.55%, but generally below 0.3%.
+
+=head2 Real-valued asin and acos
+
+For small inputs asin() and acos() may return complex numbers even
+when real numbers would be enough and correct, this happens because of
+floating-point inaccuracies. You can see these inaccuracies for
+example by trying theses:
+
+ print cos(1e-6)**2+sin(1e-6)**2 - 1,"\n";
+ printf "%.20f", cos(1e-6)**2+sin(1e-6)**2,"\n";
+
+which will print something like this
+
+ -1.11022302462516e-16
+ 0.99999999999999988898
+
+even though the expected results are of course exactly zero and one.
+The formulas used to compute asin() and acos() are quite sensitive to
+this, and therefore they might accidentally slip into the complex
+plane even when they should not. To counter this there are two
+interfaces that are guaranteed to return a real-valued output.
+
+=over 4
+
+=item asin_real
+
+ use Math::Trig qw(asin_real);
+
+ $real_angle = asin_real($input_sin);
+
+Return a real-valued arcus sine if the input is between [-1, 1],
+B<inclusive> the endpoints. For inputs greater than one, pi/2
+is returned. For inputs less than minus one, -pi/2 is returned.
+
+=item acos_real
+
+ use Math::Trig qw(acos_real);
+
+ $real_angle = acos_real($input_cos);
+
+Return a real-valued arcus cosine if the input is between [-1, 1],
+B<inclusive> the endpoints. For inputs greater than one, zero
+is returned. For inputs less than minus one, pi is returned.
+
+=back
+
+=head1 BUGS
+
+Saying C<use Math::Trig;> exports many mathematical routines in the
+caller environment and even overrides some (C<sin>, C<cos>). This is
+construed as a feature by the Authors, actually... ;-)
+
+The code is not optimized for speed, especially because we use
+C<Math::Complex> and thus go quite near complex numbers while doing
+the computations even when the arguments are not. This, however,
+cannot be completely avoided if we want things like C<asin(2)> to give
+an answer instead of giving a fatal runtime error.
+
+Do not attempt navigation using these formulas.
+
+L<Math::Complex>
+
+=head1 AUTHORS
+
+Jarkko Hietaniemi <F<jhi!at!iki.fi>> and
+Raphael Manfredi <F<Raphael_Manfredi!at!pobox.com>>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+# eof
diff --git a/Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm b/Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm
new file mode 100644
index 00000000000..91f960962f9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm
@@ -0,0 +1,31 @@
+package Memoize::AnyDBM_File;
+
+=head1 NAME
+
+Memoize::AnyDBM_File - glue to provide EXISTS for AnyDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use vars qw(@ISA $VERSION);
+$VERSION = 0.65;
+@ISA = qw(DB_File GDBM_File Memoize::NDBM_File Memoize::SDBM_File ODBM_File) unless @ISA;
+
+my $verbose = 1;
+
+my $mod;
+for $mod (@ISA) {
+# (my $truemod = $mod) =~ s/^Memoize:://;
+# my $file = "$mod.pm";
+# $file =~ s{::}{/}g;
+ if (eval "require $mod") {
+ print STDERR "AnyDBM_File => Selected $mod.\n" if $Verbose;
+ @ISA = ($mod); # if we leave @ISA alone, warnings abound
+ return 1;
+ }
+}
+
+die "No DBM package was successfully found or installed";
diff --git a/Master/tlpkg/tlperl/lib/Memoize/Expire.pm b/Master/tlpkg/tlperl/lib/Memoize/Expire.pm
new file mode 100644
index 00000000000..97e1aa44208
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/Expire.pm
@@ -0,0 +1,365 @@
+
+package Memoize::Expire;
+# require 5.00556;
+use Carp;
+$DEBUG = 0;
+$VERSION = '1.00';
+
+# This package will implement expiration by prepending a fixed-length header
+# to the font of the cached data. The format of the header will be:
+# (4-byte number of last-access-time) (For LRU when I implement it)
+# (4-byte expiration time: unsigned seconds-since-unix-epoch)
+# (2-byte number-of-uses-before-expire)
+
+sub _header_fmt () { "N N n" }
+sub _header_size () { length(_header_fmt) }
+
+# Usage: memoize func
+# TIE => [Memoize::Expire, LIFETIME => sec, NUM_USES => n,
+# TIE => [...] ]
+
+BEGIN {
+ eval {require Time::HiRes};
+ unless ($@) {
+ Time::HiRes->import('time');
+ }
+}
+
+sub TIEHASH {
+ my ($package, %args) = @_;
+ my %cache;
+ if ($args{TIE}) {
+ my ($module, @opts) = @{$args{TIE}};
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize::Expire: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %cache => $module, @opts);
+ unless ($rc) {
+ croak "Memoize::Expire: Couldn't tie hash to `$module': $@; aborting";
+ }
+ }
+ $args{LIFETIME} ||= 0;
+ $args{NUM_USES} ||= 0;
+ $args{C} = \%cache;
+ bless \%args => $package;
+}
+
+sub STORE {
+ $DEBUG and print STDERR " >> Store $_[1] $_[2]\n";
+ my ($self, $key, $value) = @_;
+ my $expire_time = $self->{LIFETIME} > 0 ? $self->{LIFETIME} + time : 0;
+ # The call that results in a value to store into the cache is the
+ # first of the NUM_USES allowed calls.
+ my $header = _make_header(time, $expire_time, $self->{NUM_USES}-1);
+ $self->{C}{$key} = $header . $value;
+ $value;
+}
+
+sub FETCH {
+ $DEBUG and print STDERR " >> Fetch cached value for $_[1]\n";
+ my ($data, $last_access, $expire_time, $num_uses_left) = _get_item($_[0]{C}{$_[1]});
+ $DEBUG and print STDERR " >> (ttl: ", ($expire_time-time()), ", nuses: $num_uses_left)\n";
+ $num_uses_left--;
+ $last_access = time;
+ _set_header(@_, $data, $last_access, $expire_time, $num_uses_left);
+ $data;
+}
+
+sub EXISTS {
+ $DEBUG and print STDERR " >> Exists $_[1]\n";
+ unless (exists $_[0]{C}{$_[1]}) {
+ $DEBUG and print STDERR " Not in underlying hash at all.\n";
+ return 0;
+ }
+ my $item = $_[0]{C}{$_[1]};
+ my ($last_access, $expire_time, $num_uses_left) = _get_header($item);
+ my $ttl = $expire_time - time;
+ if ($DEBUG) {
+ $_[0]{LIFETIME} and print STDERR " Time to live for this item: $ttl\n";
+ $_[0]{NUM_USES} and print STDERR " Uses remaining: $num_uses_left\n";
+ }
+ if ( (! $_[0]{LIFETIME} || $expire_time > time)
+ && (! $_[0]{NUM_USES} || $num_uses_left > 0 )) {
+ $DEBUG and print STDERR " (Still good)\n";
+ return 1;
+ } else {
+ $DEBUG and print STDERR " (Expired)\n";
+ return 0;
+ }
+}
+
+# Arguments: last access time, expire time, number of uses remaining
+sub _make_header {
+ pack "N N n", @_;
+}
+
+sub _strip_header {
+ substr($_[0], 10);
+}
+
+# Arguments: last access time, expire time, number of uses remaining
+sub _set_header {
+ my ($self, $key, $data, @header) = @_;
+ $self->{C}{$key} = _make_header(@header) . $data;
+}
+
+sub _get_item {
+ my $data = substr($_[0], 10);
+ my @header = unpack "N N n", substr($_[0], 0, 10);
+# print STDERR " >> _get_item: $data => $data @header\n";
+ ($data, @header);
+}
+
+# Return last access time, expire time, number of uses remaining
+sub _get_header {
+ unpack "N N n", substr($_[0], 0, 10);
+}
+
+1;
+
+=head1 NAME
+
+Memoize::Expire - Plug-in module for automatic expiration of memoized values
+
+=head1 SYNOPSIS
+
+ use Memoize;
+ use Memoize::Expire;
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses;
+
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache ];
+
+=head1 DESCRIPTION
+
+Memoize::Expire is a plug-in module for Memoize. It allows the cached
+values for memoized functions to expire automatically. This manual
+assumes you are already familiar with the Memoize module. If not, you
+should study that manual carefully first, paying particular attention
+to the HASH feature.
+
+Memoize::Expire is a layer of software that you can insert in between
+Memoize itself and whatever underlying package implements the cache.
+The layer presents a hash variable whose values expire whenever they
+get too old, have been used too often, or both. You tell C<Memoize> to
+use this forgetful hash as its cache instead of the default, which is
+an ordinary hash.
+
+To specify a real-time timeout, supply the C<LIFETIME> option with a
+numeric value. Cached data will expire after this many seconds, and
+will be looked up afresh when it expires. When a data item is looked
+up afresh, its lifetime is reset.
+
+If you specify C<NUM_USES> with an argument of I<n>, then each cached
+data item will be discarded and looked up afresh after the I<n>th time
+you access it. When a data item is looked up afresh, its number of
+uses is reset.
+
+If you specify both arguments, data will be discarded from the cache
+when either expiration condition holds.
+
+Memoize::Expire uses a real hash internally to store the cached data.
+You can use the C<HASH> option to Memoize::Expire to supply a tied
+hash in place of the ordinary hash that Memoize::Expire will normally
+use. You can use this feature to add Memoize::Expire as a layer in
+between a persistent disk hash and Memoize. If you do this, you get a
+persistent disk cache whose entries expire automatically. For
+example:
+
+ # Memoize
+ # |
+ # Memoize::Expire enforces data expiration policy
+ # |
+ # DB_File implements persistence of data in a disk file
+ # |
+ # Disk file
+
+ use Memoize;
+ use Memoize::Expire;
+ use DB_File;
+
+ # Set up persistence
+ tie my %disk_cache => 'DB_File', $filename, O_CREAT|O_RDWR, 0666];
+
+ # Set up expiration policy, supplying persistent hash as a target
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses,
+ HASH => \%disk_cache;
+
+ # Set up memoization, supplying expiring persistent hash for cache
+ memoize 'function', SCALAR_CACHE => [ HASH => \%cache ];
+
+=head1 INTERFACE
+
+There is nothing special about Memoize::Expire. It is just an
+example. If you don't like the policy that it implements, you are
+free to write your own expiration policy module that implements
+whatever policy you desire. Here is how to do that. Let us suppose
+that your module will be named MyExpirePolicy.
+
+Short summary: You need to create a package that defines four methods:
+
+=over 4
+
+=item
+TIEHASH
+
+Construct and return cache object.
+
+=item
+EXISTS
+
+Given a function argument, is the corresponding function value in the
+cache, and if so, is it fresh enough to use?
+
+=item
+FETCH
+
+Given a function argument, look up the corresponding function value in
+the cache and return it.
+
+=item
+STORE
+
+Given a function argument and the corresponding function value, store
+them into the cache.
+
+=item
+CLEAR
+
+(Optional.) Flush the cache completely.
+
+=back
+
+The user who wants the memoization cache to be expired according to
+your policy will say so by writing
+
+ tie my %cache => 'MyExpirePolicy', args...;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+This will invoke C<< MyExpirePolicy->TIEHASH(args) >>.
+MyExpirePolicy::TIEHASH should do whatever is appropriate to set up
+the cache, and it should return the cache object to the caller.
+
+For example, MyExpirePolicy::TIEHASH might create an object that
+contains a regular Perl hash (which it will to store the cached
+values) and some extra information about the arguments and how old the
+data is and things like that. Let us call this object `C'.
+
+When Memoize needs to check to see if an entry is in the cache
+already, it will invoke C<< C->EXISTS(key) >>. C<key> is the normalized
+function argument. MyExpirePolicy::EXISTS should return 0 if the key
+is not in the cache, or if it has expired, and 1 if an unexpired value
+is in the cache. It should I<not> return C<undef>, because there is a
+bug in some versions of Perl that will cause a spurious FETCH if the
+EXISTS method returns C<undef>.
+
+If your EXISTS function returns true, Memoize will try to fetch the
+cached value by invoking C<< C->FETCH(key) >>. MyExpirePolicy::FETCH should
+return the cached value. Otherwise, Memoize will call the memoized
+function to compute the appropriate value, and will store it into the
+cache by calling C<< C->STORE(key, value) >>.
+
+Here is a very brief example of a policy module that expires each
+cache item after ten seconds.
+
+ package Memoize::TenSecondExpire;
+
+ sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+ bless $cache => $package;
+ }
+
+ sub EXISTS {
+ my ($cache, $key) = @_;
+ if (exists $cache->{$key} &&
+ $cache->{$key}{EXPIRE_TIME} > time) {
+ return 1
+ } else {
+ return 0; # Do NOT return `undef' here.
+ }
+ }
+
+ sub FETCH {
+ my ($cache, $key) = @_;
+ return $cache->{$key}{VALUE};
+ }
+
+ sub STORE {
+ my ($cache, $key, $newvalue) = @_;
+ $cache->{$key}{VALUE} = $newvalue;
+ $cache->{$key}{EXPIRE_TIME} = time + 10;
+ }
+
+To use this expiration policy, the user would say
+
+ use Memoize;
+ tie my %cache10sec => 'Memoize::TenSecondExpire';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache10sec];
+
+Memoize would then call C<function> whenever a cached value was
+entirely absent or was older than ten seconds.
+
+You should always support a C<HASH> argument to C<TIEHASH> that ties
+the underlying cache so that the user can specify that the cache is
+also persistent or that it has some other interesting semantics. The
+example above demonstrates how to do this, as does C<Memoize::Expire>.
+
+=head1 ALTERNATIVES
+
+Brent Powers has a C<Memoize::ExpireLRU> module that was designed to
+work with Memoize and provides expiration of least-recently-used data.
+The cache is held at a fixed number of entries, and when new data
+comes in, the least-recently used data is expired. See
+L<http://search.cpan.org/search?mode=module&query=ExpireLRU>.
+
+Joshua Chamas's Tie::Cache module may be useful as an expiration
+manager. (If you try this, let me know how it works out.)
+
+If you develop any useful expiration managers that you think should be
+distributed with Memoize, please let me know.
+
+=head1 CAVEATS
+
+This module is experimental, and may contain bugs. Please report bugs
+to the address below.
+
+Number-of-uses is stored as a 16-bit unsigned integer, so can't exceed
+65535.
+
+Because of clock granularity, expiration times may occur up to one
+second sooner than you expect. For example, suppose you store a value
+with a lifetime of ten seconds, and you store it at 12:00:00.998 on a
+certain day. Memoize will look at the clock and see 12:00:00. Then
+9.01 seconds later, at 12:00:10.008 you try to read it back. Memoize
+will look at the clock and see 12:00:10 and conclude that the value
+has expired. This will probably not occur if you have
+C<Time::HiRes> installed.
+
+=head1 AUTHOR
+
+Mark-Jason Dominus (mjd-perl-memoize+@plover.com)
+
+Mike Cariaso provided valuable insight into the best way to solve this
+problem.
+
+=head1 SEE ALSO
+
+perl(1)
+
+The Memoize man page.
+
+http://www.plover.com/~mjd/perl/Memoize/ (for news and updates)
+
+I maintain a mailing list on which I occasionally announce new
+versions of Memoize. The list is for announcements only, not
+discussion. To join, send an empty message to
+mjd-perl-memoize-request@Plover.com.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm b/Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm
new file mode 100644
index 00000000000..e52c09a3bf3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm
@@ -0,0 +1,52 @@
+package Memoize::ExpireFile;
+
+=head1 NAME
+
+Memoize::ExpireFile - test for Memoize expiration semantics
+
+=head1 DESCRIPTION
+
+See L<Memoize::Expire>.
+
+=cut
+
+$VERSION = 1.01;
+use Carp;
+
+my $Zero = pack("N", 0);
+
+sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+ bless {ARGS => \%args, C => $cache} => $package;
+}
+
+
+sub STORE {
+# print "Expiry manager STORE handler\n";
+ my ($self, $key, $data) = @_;
+ my $cache = $self->{C};
+ my $cur_date = pack("N", (stat($key))[9]);
+ $cache->{"C$key"} = $data;
+ $cache->{"T$key"} = $cur_date;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ $self->{C}{"C$key"};
+}
+
+sub EXISTS {
+# print "Expiry manager EXISTS handler\n";
+ my ($self, $key) = @_;
+ my $cache_date = $self->{C}{"T$key"} || $Zero;
+ my $file_date = pack("N", (stat($key))[9]);#
+# if ($self->{ARGS}{CHECK_DATE} && $old_date gt $cur_date) {
+# return $self->{ARGS}{CHECK_DATE}->($key, $old_date, $cur_date);
+# }
+ my $res = $cache_date ge $file_date;
+# print $res ? "... still good\n" : "... expired\n";
+ $res;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm b/Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm
new file mode 100644
index 00000000000..729f6b98506
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm
@@ -0,0 +1,49 @@
+package Memoize::ExpireTest;
+
+=head1 NAME
+
+Memoize::ExpireTest - test for Memoize expiration semantics
+
+=head1 DESCRIPTION
+
+This module is just for testing expiration semantics. It's not a very
+good example of how to write an expiration module.
+
+If you are looking for an example, I recommend that you look at the
+simple example in the Memoize::Expire documentation, or at the code
+for Memoize::Expire itself.
+
+If you have questions, I will be happy to answer them if you send them
+to mjd-perl-memoize+@plover.com.
+
+=cut
+
+$VERSION = 0.65;
+my %cache;
+
+sub TIEHASH {
+ my ($pack) = @_;
+ bless \%cache => $pack;
+}
+
+sub EXISTS {
+ my ($cache, $key) = @_;
+ exists $cache->{$key} ? 1 : 0;
+}
+
+sub FETCH {
+ my ($cache, $key) = @_;
+ $cache->{$key};
+}
+
+sub STORE {
+ my ($cache, $key, $val) = @_;
+ $cache->{$key} = $val;
+}
+
+sub expire {
+ my ($key) = @_;
+ delete $cache{$key};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm b/Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm
new file mode 100644
index 00000000000..96eabfbb7c8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm
@@ -0,0 +1,77 @@
+package Memoize::NDBM_File;
+
+=head1 NAME
+
+Memoize::NDBM_File - glue to provide EXISTS for NDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use NDBM_File;
+@ISA = qw(NDBM_File);
+$VERSION = 0.65;
+
+$Verbose = 0;
+
+sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::NDBM_File\n";
+}
+
+sub import {
+ warn "Importing Memoize::NDBM_File\n" if $Verbose;
+}
+
+
+my %keylist;
+
+# This is so ridiculous...
+sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+}
+
+sub EXISTS {
+ warn "Memoize::NDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::NDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+}
+
+sub DEFINED {
+ warn "Memoize::NDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+}
+
+sub DESTROY {
+ warn "Memoize::NDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+}
+
+# Maybe establish the keylist at TIEHASH time instead?
+
+sub STORE {
+ warn "Memoize::NDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+}
+
+
+
+# Inherit FETCH and TIEHASH
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm b/Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm
new file mode 100644
index 00000000000..f66273f2747
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm
@@ -0,0 +1,75 @@
+package Memoize::SDBM_File;
+
+=head1 NAME
+
+Memoize::SDBM_File - glue to provide EXISTS for SDBM_File for Storable use
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use SDBM_File;
+@ISA = qw(SDBM_File);
+$VERSION = 0.65;
+
+$Verbose = 0;
+
+sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::SDBM_File\n";
+}
+
+sub import {
+ warn "Importing Memoize::SDBM_File\n" if $Verbose;
+}
+
+
+my %keylist;
+
+# This is so ridiculous...
+sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+}
+
+sub EXISTS {
+ warn "Memoize::SDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::SDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+}
+
+sub DEFINED {
+ warn "Memoize::SDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+}
+
+sub DESTROY {
+ warn "Memoize::SDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+}
+
+# Maybe establish the keylist at TIEHASH time instead?
+
+sub STORE {
+ warn "Memoize::SDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+}
+
+# Inherit FETCH and TIEHASH
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Memoize/Storable.pm b/Master/tlpkg/tlperl/lib/Memoize/Storable.pm
new file mode 100644
index 00000000000..4c29dd7eb8f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize/Storable.pm
@@ -0,0 +1,72 @@
+package Memoize::Storable;
+
+=head1 NAME
+
+Memoize::Storable - store Memoized data in Storable database
+
+=head1 DESCRIPTION
+
+See L<Memoize>.
+
+=cut
+
+use Storable ();
+$VERSION = 0.65;
+$Verbose = 0;
+
+sub TIEHASH {
+ require Carp if $Verbose;
+ my $package = shift;
+ my $filename = shift;
+ my $truehash = (-e $filename) ? Storable::retrieve($filename) : {};
+ my %options;
+ print STDERR "Memoize::Storable::TIEHASH($filename, @_)\n" if $Verbose;
+ @options{@_} = ();
+ my $self =
+ {FILENAME => $filename,
+ H => $truehash,
+ OPTIONS => \%options
+ };
+ bless $self => $package;
+}
+
+sub STORE {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::STORE(@_)\n" if $Verbose;
+ $self->{H}{$_[0]} = $_[1];
+}
+
+sub FETCH {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::FETCH(@_)\n" if $Verbose;
+ $self->{H}{$_[0]};
+}
+
+sub EXISTS {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::EXISTS(@_)\n" if $Verbose;
+ exists $self->{H}{$_[0]};
+}
+
+sub DESTROY {
+ require Carp if $Verbose;
+ my $self= shift;
+ print STDERR "Memoize::Storable::DESTROY(@_)\n" if $Verbose;
+ if ($self->{OPTIONS}{'nstore'}) {
+ Storable::nstore($self->{H}, $self->{FILENAME});
+ } else {
+ Storable::store($self->{H}, $self->{FILENAME});
+ }
+}
+
+sub FIRSTKEY {
+ 'Fake hash from Memoize::Storable';
+}
+
+sub NEXTKEY {
+ undef;
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/Cmd.pm b/Master/tlpkg/tlperl/lib/Net/Cmd.pm
new file mode 100644
index 00000000000..4f0e4449f80
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Cmd.pm
@@ -0,0 +1,783 @@
+# Net::Cmd.pm
+#
+# Copyright (c) 1995-2006 Graham Barr <gbarr@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";
+@ISA = qw(Exporter);
+@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@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
diff --git a/Master/tlpkg/tlperl/lib/Net/Config.pm b/Master/tlpkg/tlperl/lib/Net/Config.pm
new file mode 100644
index 00000000000..db51c1fc0d2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Config.pm
@@ -0,0 +1,312 @@
+# Net::Config.pm
+#
+# Copyright (c) 2000 Graham Barr <gbarr@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;
+
+@EXPORT = qw(%NetConfig);
+@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@remote.host
+ PASS pass
+
+=item 2
+
+ USER fwuser
+ PASS fwpass
+ USER user@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@fwuser@remote.site
+ PASS pass@fwpass
+
+=item 6
+
+ USER fwuser@remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+
+=item 7
+
+ USER user@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
diff --git a/Master/tlpkg/tlperl/lib/Net/Domain.pm b/Master/tlpkg/tlperl/lib/Net/Domain.pm
new file mode 100644
index 00000000000..330909da49d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Domain.pm
@@ -0,0 +1,347 @@
+# Net::Domain.pm
+#
+# Copyright (c) 1995-1998 Graham Barr <gbarr@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;
+
+@ISA = qw(Exporter);
+@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@pobox.com>.
+Adapted from Sys::Hostname by David Sundstrom <sunds@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
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP.pm b/Master/tlpkg/tlperl/lib/Net/FTP.pm
new file mode 100644
index 00000000000..9ed6d385d9c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP.pm
@@ -0,0 +1,1829 @@
+# Net::FTP.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr@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@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';
+@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@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@WPI.EDU> - for the suggestion of creating directories
+recursively.
+
+Nathan Torkington <gnat@frii.com> - for some input on the documentation.
+
+Roderick Schertler <roderick@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
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/A.pm b/Master/tlpkg/tlperl/lib/Net/FTP/A.pm
new file mode 100644
index 00000000000..427d02b19e9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP/A.pm
@@ -0,0 +1,111 @@
+##
+## Package to read/write on ASCII data connections
+##
+
+package Net::FTP::A;
+use strict;
+use vars qw(@ISA $buf $VERSION);
+use Carp;
+
+require Net::FTP::dataconn;
+
+@ISA = qw(Net::FTP::dataconn);
+$VERSION = "1.18";
+
+
+sub read {
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'read($buf,$size,[$offset])';
+ my $timeout = @_ ? shift: $data->timeout;
+
+ if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+ $blksize = $size if $size > $blksize;
+
+ my $l = 0;
+ my $n;
+
+ READ:
+ {
+ my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
+
+ $data->can_read($timeout)
+ or croak "Timeout";
+
+ if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
+ ${*$data}{'net_ftp_bytesread'} += $n;
+ ${*$data}{'net_ftp_cr'} =
+ substr($readbuf, -1) eq "\015"
+ ? chop($readbuf)
+ : undef;
+ }
+ else {
+ return undef
+ unless defined $n;
+
+ ${*$data}{'net_ftp_eof'} = 1;
+ }
+
+ $readbuf =~ s/\015\012/\n/sgo;
+ ${*$data} .= $readbuf;
+
+ unless (length(${*$data})) {
+
+ redo READ
+ if ($n > 0);
+
+ $size = length(${*$data})
+ if ($n == 0);
+ }
+ }
+ }
+
+ $buf = substr(${*$data}, 0, $size);
+ substr(${*$data}, 0, $size) = '';
+
+ length $buf;
+}
+
+
+sub write {
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
+
+ my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/;
+ $tmp =~ s/([^\015])\012/$1\015\012/sg if $nr;
+ $tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'};
+ ${*$data}{'net_ftp_outcr'} = substr($tmp, -1) eq "\015";
+
+ # If the remote server has closed the connection we will be signal'd
+ # when we write. This can happen if the disk on the remote server fills up
+
+ local $SIG{PIPE} = 'IGNORE'
+ unless ($SIG{PIPE} || '') eq 'IGNORE'
+ or $^O eq 'MacOS';
+
+ my $len = length($tmp);
+ my $off = 0;
+ my $wrote = 0;
+
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+
+ while ($len) {
+ $data->can_write($timeout)
+ or croak "Timeout";
+
+ $off += $wrote;
+ $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len);
+ return undef
+ unless defined($wrote);
+ $len -= $wrote;
+ }
+
+ $size;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/E.pm b/Master/tlpkg/tlperl/lib/Net/FTP/E.pm
new file mode 100644
index 00000000000..d480cd72955
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP/E.pm
@@ -0,0 +1,8 @@
+package Net::FTP::E;
+
+require Net::FTP::I;
+
+@ISA = qw(Net::FTP::I);
+$VERSION = "0.01";
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/I.pm b/Master/tlpkg/tlperl/lib/Net/FTP/I.pm
new file mode 100644
index 00000000000..449bb99eab6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP/I.pm
@@ -0,0 +1,80 @@
+##
+## Package to read/write on BINARY data connections
+##
+
+package Net::FTP::I;
+
+use vars qw(@ISA $buf $VERSION);
+use Carp;
+
+require Net::FTP::dataconn;
+
+@ISA = qw(Net::FTP::dataconn);
+$VERSION = "1.12";
+
+
+sub read {
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'read($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
+
+ my $n;
+
+ if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) {
+ $data->can_read($timeout)
+ or croak "Timeout";
+
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+ $blksize = $size if $size > $blksize;
+
+ unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) {
+ return undef unless defined $n;
+ ${*$data}{'net_ftp_eof'} = 1;
+ }
+ }
+
+ $buf = substr(${*$data}, 0, $size);
+
+ $n = length($buf);
+
+ substr(${*$data}, 0, $n) = '';
+
+ ${*$data}{'net_ftp_bytesread'} += $n;
+
+ $n;
+}
+
+
+sub write {
+ my $data = shift;
+ local *buf = \$_[0];
+ shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift: $data->timeout;
+
+ # If the remote server has closed the connection we will be signal'd
+ # when we write. This can happen if the disk on the remote server fills up
+
+ local $SIG{PIPE} = 'IGNORE'
+ unless ($SIG{PIPE} || '') eq 'IGNORE'
+ or $^O eq 'MacOS';
+ my $sent = $size;
+ my $off = 0;
+
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+ while ($sent > 0) {
+ $data->can_write($timeout)
+ or croak "Timeout";
+
+ my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off);
+ return undef unless defined($n);
+ $sent -= $n;
+ $off += $n;
+ }
+
+ $size;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/L.pm b/Master/tlpkg/tlperl/lib/Net/FTP/L.pm
new file mode 100644
index 00000000000..f7423cb9f95
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP/L.pm
@@ -0,0 +1,8 @@
+package Net::FTP::L;
+
+require Net::FTP::I;
+
+@ISA = qw(Net::FTP::I);
+$VERSION = "0.01";
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm b/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
new file mode 100644
index 00000000000..e7645cbd930
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm
@@ -0,0 +1,124 @@
+##
+## Generic data connection package
+##
+
+package Net::FTP::dataconn;
+
+use Carp;
+use vars qw(@ISA $timeout $VERSION);
+use Net::Cmd;
+use Errno;
+
+$VERSION = '0.11';
+@ISA = qw(IO::Socket::INET);
+
+
+sub reading {
+ my $data = shift;
+ ${*$data}{'net_ftp_bytesread'} = 0;
+}
+
+
+sub abort {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ # no need to abort if we have finished the xfer
+ return $data->close
+ if ${*$data}{'net_ftp_eof'};
+
+ # for some reason if we continously open RETR connections and not
+ # read a single byte, then abort them after a while the server will
+ # close our connection, this prevents the unexpected EOF on the
+ # command channel -- GMB
+ if (exists ${*$data}{'net_ftp_bytesread'}
+ && (${*$data}{'net_ftp_bytesread'} == 0))
+ {
+ my $buf = "";
+ my $timeout = $data->timeout;
+ $data->can_read($timeout) && sysread($data, $buf, 1);
+ }
+
+ ${*$data}{'net_ftp_eof'} = 1; # fake
+
+ $ftp->abort; # this will close me
+}
+
+
+sub _close {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ $data->SUPER::close();
+
+ delete ${*$ftp}{'net_ftp_dataconn'}
+ if exists ${*$ftp}{'net_ftp_dataconn'}
+ && $data == ${*$ftp}{'net_ftp_dataconn'};
+}
+
+
+sub close {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
+ my $junk;
+ $data->read($junk, 1, 0);
+ return $data->abort unless ${*$data}{'net_ftp_eof'};
+ }
+
+ $data->_close;
+
+ $ftp->response() == CMD_OK
+ && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
+ && (${*$ftp}{'net_ftp_unique'} = $1);
+
+ $ftp->status == CMD_OK;
+}
+
+
+sub _select {
+ my ($data, $timeout, $do_read) = @_;
+ my ($rin, $rout, $win, $wout, $tout, $nfound);
+
+ vec($rin = '', fileno($data), 1) = 1;
+
+ ($win, $rin) = ($rin, $win) unless $do_read;
+
+ while (1) {
+ $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout);
+
+ last if $nfound >= 0;
+
+ croak "select: $!"
+ unless $!{EINTR};
+ }
+
+ $nfound;
+}
+
+
+sub can_read {
+ _select(@_[0, 1], 1);
+}
+
+
+sub can_write {
+ _select(@_[0, 1], 0);
+}
+
+
+sub cmd {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_cmd'};
+}
+
+
+sub bytes_read {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_bytesread'} || 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Net/NNTP.pm b/Master/tlpkg/tlperl/lib/Net/NNTP.pm
new file mode 100644
index 00000000000..a742aed04c8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/NNTP.pm
@@ -0,0 +1,1140 @@
+# Net::NNTP.pm
+#
+# Copyright (c) 1995-1997 Graham Barr <gbarr@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";
+@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@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
diff --git a/Master/tlpkg/tlperl/lib/Net/Netrc.pm b/Master/tlpkg/tlperl/lib/Net/Netrc.pm
new file mode 100644
index 00000000000..28c826b38cd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Netrc.pm
@@ -0,0 +1,325 @@
+# Net::Netrc.pm
+#
+# Copyright (c) 1995-1998 Graham Barr <gbarr@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@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@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
diff --git a/Master/tlpkg/tlperl/lib/Net/POP3.pm b/Master/tlpkg/tlperl/lib/Net/POP3.pm
new file mode 100644
index 00000000000..8381c81815e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/POP3.pm
@@ -0,0 +1,742 @@
+# Net::POP3.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr@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";
+
+@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@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
diff --git a/Master/tlpkg/tlperl/lib/Net/Ping.pm b/Master/tlpkg/tlperl/lib/Net/Ping.pm
new file mode 100644
index 00000000000..e9fff93eeaa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Ping.pm
@@ -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;
+
+@ISA = qw(Exporter);
+@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@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@cpan.org (Rob Brown)
+
+ External protocol:
+ colinm@cpan.org (Colin McMillen)
+
+ Stream protocol:
+ bronson@trestle.com (Scott Bronson)
+
+ Original pingecho():
+ karrer@bernina.ethz.ch (Andreas Karrer)
+ pmarquess@bfsec.bt.co.uk (Paul Marquess)
+
+ Original Net::Ping author:
+ mose@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.86 2003/06/27 21:31:07 rob Exp $
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Net/SMTP.pm b/Master/tlpkg/tlperl/lib/Net/SMTP.pm
new file mode 100644
index 00000000000..a28496d6886
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/SMTP.pm
@@ -0,0 +1,867 @@
+# Net::SMTP.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr@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";
+
+@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@domain WRONG
+ "funny user"@domain RIGHT, recommended
+ <"funny user"@domain> OK
+
+=head1 SEE ALSO
+
+L<Net::Cmd>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@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
diff --git a/Master/tlpkg/tlperl/lib/Net/Time.pm b/Master/tlpkg/tlperl/lib/Net/Time.pm
new file mode 100644
index 00000000000..6f1dd04586e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/Time.pm
@@ -0,0 +1,151 @@
+# Net::Time.pm
+#
+# Copyright (c) 1995-2004 Graham Barr <gbarr@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;
+
+@ISA = qw(Exporter);
+@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@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
diff --git a/Master/tlpkg/tlperl/lib/Net/hostent.pm b/Master/tlpkg/tlperl/lib/Net/hostent.pm
new file mode 100644
index 00000000000..3a2fc013877
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/hostent.pm
@@ -0,0 +1,151 @@
+package Net::hostent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(gethostbyname gethostbyaddr gethost);
+ @EXPORT_OK = qw(
+ $h_name @h_aliases
+ $h_addrtype $h_length
+ @h_addr_list $h_addr
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::hostent' => [
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ 'length' => '$',
+ addr_list => '@',
+];
+
+sub addr { shift->addr_list->[0] }
+
+sub populate (@) {
+ return unless @_;
+ my $hob = new();
+ $h_name = $hob->[0] = $_[0];
+ @h_aliases = @{ $hob->[1] } = split ' ', $_[1];
+ $h_addrtype = $hob->[2] = $_[2];
+ $h_length = $hob->[3] = $_[3];
+ $h_addr = $_[4];
+ @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ];
+ return $hob;
+}
+
+sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) }
+
+sub gethostbyaddr ($;$) {
+ my ($addr, $addrtype);
+ $addr = shift;
+ require Socket unless @_;
+ $addrtype = @_ ? shift : Socket::AF_INET();
+ populate(CORE::gethostbyaddr($addr, $addrtype))
+}
+
+sub gethost($) {
+ if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
+ require Socket;
+ &gethostbyaddr(Socket::inet_aton(shift));
+ } else {
+ &gethostbyname;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::hostent - by-name interface to Perl's built-in gethost*() functions
+
+=head1 SYNOPSIS
+
+ use Net::hostent;
+
+=head1 DESCRIPTION
+
+This module's default exports override the core gethostbyname() and
+gethostbyaddr() functions, replacing them with versions that return
+"Net::hostent" objects. This object has methods that return the similarly
+named structure field name from the C's hostent structure from F<netdb.h>;
+namely name, aliases, addrtype, length, and addr_list. The aliases and
+addr_list methods return array reference, the rest scalars. The addr
+method is equivalent to the zeroth element in the addr_list array
+reference.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to
+$h_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $host_obj-E<gt>aliases()
+}> would be simply @h_aliases.
+
+The gethost() function is a simple front-end that forwards a numeric
+argument to gethostbyaddr() by way of Socket::inet_aton, and the rest
+to gethostbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+ use Net::hostent;
+ use Socket;
+
+ @ARGV = ('netscape.com') unless @ARGV;
+
+ for $host ( @ARGV ) {
+
+ unless ($h = gethost($host)) {
+ warn "$0: no such host: $host\n";
+ next;
+ }
+
+ printf "\n%s is %s%s\n",
+ $host,
+ lc($h->name) eq lc($host) ? "" : "*really* ",
+ $h->name;
+
+ print "\taliases are ", join(", ", @{$h->aliases}), "\n"
+ if @{$h->aliases};
+
+ if ( @{$h->addr_list} > 1 ) {
+ my $i;
+ for $addr ( @{$h->addr_list} ) {
+ printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr);
+ }
+ } else {
+ printf "\taddress is [%s]\n", inet_ntoa($h->addr);
+ }
+
+ if ($h = gethostbyaddr($h->addr)) {
+ if (lc($h->name) ne lc($host)) {
+ printf "\tThat addr reverses to host %s!\n", $h->name;
+ $host = $h->name;
+ redo;
+ }
+ }
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod b/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod
new file mode 100644
index 00000000000..e6ec362f36a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod
@@ -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@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@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@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@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<&gt&gt&gt&gt> 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.
+
diff --git a/Master/tlpkg/tlperl/lib/Net/netent.pm b/Master/tlpkg/tlperl/lib/Net/netent.pm
new file mode 100644
index 00000000000..f7d32cb9254
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/netent.pm
@@ -0,0 +1,169 @@
+package Net::netent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.00';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getnetbyname getnetbyaddr getnet);
+ @EXPORT_OK = qw(
+ $n_name @n_aliases
+ $n_addrtype $n_net
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::netent' => [
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ net => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $nob = new();
+ $n_name = $nob->[0] = $_[0];
+ @n_aliases = @{ $nob->[1] } = split ' ', $_[1];
+ $n_addrtype = $nob->[2] = $_[2];
+ $n_net = $nob->[3] = $_[3];
+ return $nob;
+}
+
+sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) }
+
+sub getnetbyaddr ($;$) {
+ my ($net, $addrtype);
+ $net = shift;
+ require Socket if @_;
+ $addrtype = @_ ? shift : Socket::AF_INET();
+ populate(CORE::getnetbyaddr($net, $addrtype))
+}
+
+sub getnet($) {
+ if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
+ require Socket;
+ &getnetbyaddr(Socket::inet_aton(shift));
+ } else {
+ &getnetbyname;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::netent - by-name interface to Perl's built-in getnet*() functions
+
+=head1 SYNOPSIS
+
+ use Net::netent qw(:FIELDS);
+ getnetbyname("loopback") or die "bad net";
+ printf "%s is %08X\n", $n_name, $n_net;
+
+ use Net::netent;
+
+ $n = getnetbyname("loopback") or die "bad net";
+ { # there's gotta be a better way, eh?
+ @bytes = unpack("C4", pack("N", $n->net));
+ shift @bytes while @bytes && $bytes[0] == 0;
+ }
+ printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes;
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getnetbyname() and
+getnetbyaddr() functions, replacing them with versions that return
+"Net::netent" objects. This object has methods that return the similarly
+named structure field name from the C's netent structure from F<netdb.h>;
+namely name, aliases, addrtype, and net. The aliases
+method returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to
+$n_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $net_obj-E<gt>aliases()
+}> would be simply @n_aliases.
+
+The getnet() function is a simple front-end that forwards a numeric
+argument to getnetbyaddr(), and the rest
+to getnetbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+The getnet() functions do this in the Perl core:
+
+ sv_setiv(sv, (I32)nent->n_net);
+
+The gethost() functions do this in the Perl core:
+
+ sv_setpvn(sv, hent->h_addr, len);
+
+That means that the address comes back in binary for the
+host functions, and as a regular perl integer for the net ones.
+This seems a bug, but here's how to deal with it:
+
+ use strict;
+ use Socket;
+ use Net::netent;
+
+ @ARGV = ('loopback') unless @ARGV;
+
+ my($n, $net);
+
+ for $net ( @ARGV ) {
+
+ unless ($n = getnetbyname($net)) {
+ warn "$0: no such net: $net\n";
+ next;
+ }
+
+ printf "\n%s is %s%s\n",
+ $net,
+ lc($n->name) eq lc($net) ? "" : "*really* ",
+ $n->name;
+
+ print "\taliases are ", join(", ", @{$n->aliases}), "\n"
+ if @{$n->aliases};
+
+ # this is stupid; first, why is this not in binary?
+ # second, why am i going through these convolutions
+ # to make it looks right
+ {
+ my @a = unpack("C4", pack("N", $n->net));
+ shift @a while @a && $a[0] == 0;
+ printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a;
+ }
+
+ if ($n = getnetbyaddr($n->net)) {
+ if (lc($n->name) ne lc($net)) {
+ printf "\tThat addr reverses to net %s!\n", $n->name;
+ $net = $n->name;
+ redo;
+ }
+ }
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/protoent.pm b/Master/tlpkg/tlperl/lib/Net/protoent.pm
new file mode 100644
index 00000000000..2cbccad3cbc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/protoent.pm
@@ -0,0 +1,96 @@
+package Net::protoent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.00';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto);
+ @EXPORT_OK = qw( $p_name @p_aliases $p_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::protoent' => [
+ name => '$',
+ aliases => '@',
+ proto => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $pob = new();
+ $p_name = $pob->[0] = $_[0];
+ @p_aliases = @{ $pob->[1] } = split ' ', $_[1];
+ $p_proto = $pob->[2] = $_[2];
+ return $pob;
+}
+
+sub getprotoent ( ) { populate(CORE::getprotoent()) }
+sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) }
+sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) }
+
+sub getproto ($;$) {
+ no strict 'refs';
+ return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::protoent - by-name interface to Perl's built-in getproto*() functions
+
+=head1 SYNOPSIS
+
+ use Net::protoent;
+ $p = getprotobyname(shift || 'tcp') || die "no proto";
+ printf "proto for %s is %d, aliases are %s\n",
+ $p->name, $p->proto, "@{$p->aliases}";
+
+ use Net::protoent qw(:FIELDS);
+ getprotobyname(shift || 'tcp') || die "no proto";
+ print "proto for $p_name is $p_proto, aliases are @p_aliases\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getprotoent(),
+getprotobyname(), and getnetbyport() functions, replacing them with
+versions that return "Net::protoent" objects. They take default
+second arguments of "tcp". This object has methods that return the
+similarly named structure field name from the C's protoent structure
+from F<netdb.h>; namely name, aliases, and proto. The aliases method
+returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to
+$p_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $proto_obj-E<gt>aliases()
+}> would be simply @p_aliases.
+
+The getproto() function is a simple front-end that forwards a numeric
+argument to getprotobyport(), and the rest to getprotobyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Net/servent.pm b/Master/tlpkg/tlperl/lib/Net/servent.pm
new file mode 100644
index 00000000000..78a16814555
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Net/servent.pm
@@ -0,0 +1,113 @@
+package Net::servent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getservbyname getservbyport getservent getserv);
+ @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::servent' => [
+ name => '$',
+ aliases => '@',
+ port => '$',
+ proto => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $sob = new();
+ $s_name = $sob->[0] = $_[0];
+ @s_aliases = @{ $sob->[1] } = split ' ', $_[1];
+ $s_port = $sob->[2] = $_[2];
+ $s_proto = $sob->[3] = $_[3];
+ return $sob;
+}
+
+sub getservent ( ) { populate(CORE::getservent()) }
+sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) }
+sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) }
+
+sub getserv ($;$) {
+ no strict 'refs';
+ return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::servent - by-name interface to Perl's built-in getserv*() functions
+
+=head1 SYNOPSIS
+
+ use Net::servent;
+ $s = getservbyname(shift || 'ftp') || die "no service";
+ printf "port for %s is %s, aliases are %s\n",
+ $s->name, $s->port, "@{$s->aliases}";
+
+ use Net::servent qw(:FIELDS);
+ getservbyname(shift || 'ftp') || die "no service";
+ print "port for $s_name is $s_port, aliases are @s_aliases\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getservent(),
+getservbyname(), and
+getnetbyport() functions, replacing them with versions that return
+"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly
+named structure field name from the C's servent structure from F<netdb.h>;
+namely name, aliases, port, and proto. The aliases
+method returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<s_>. Thus, C<$serv_obj-E<gt>name()> corresponds to
+$s_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $serv_obj-E<gt>aliases()}>
+would be simply @s_aliases.
+
+The getserv() function is a simple front-end that forwards a numeric
+argument to getservbyport(), and the rest to getservbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+ use Net::servent qw(:FIELDS);
+
+ while (@ARGV) {
+ my ($service, $proto) = ((split m!/!, shift), 'tcp');
+ my $valet = getserv($service, $proto);
+ unless ($valet) {
+ warn "$0: No service: $service/$proto\n"
+ next;
+ }
+ printf "service $service/$proto is port %d\n", $valet->port;
+ print "alias are @s_aliases\n" if @s_aliases;
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Object/Accessor.pm b/Master/tlpkg/tlperl/lib/Object/Accessor.pm
new file mode 100644
index 00000000000..7166200af19
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Object/Accessor.pm
@@ -0,0 +1,819 @@
+package Object::Accessor;
+
+use strict;
+use Carp qw[carp croak];
+use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
+use Params::Check qw[allow];
+use Data::Dumper;
+
+### some objects might have overload enabled, we'll need to
+### disable string overloading for callbacks
+require overload;
+
+$VERSION = '0.36';
+$FATAL = 0;
+$DEBUG = 0;
+
+use constant VALUE => 0; # array index in the hash value
+use constant ALLOW => 1; # array index in the hash value
+use constant ALIAS => 2; # array index in the hash value
+
+=head1 NAME
+
+Object::Accessor - interface to create per object accessors
+
+=head1 SYNOPSIS
+
+ ### using the object
+ $obj = Object::Accessor->new; # create object
+ $obj = Object::Accessor->new(@list); # create object with accessors
+ $obj = Object::Accessor->new(\%h); # create object with accessors
+ # and their allow handlers
+
+ $bool = $obj->mk_accessors('foo'); # create accessors
+ $bool = $obj->mk_accessors( # create accessors with input
+ {foo => ALLOW_HANDLER} ); # validation
+
+ $bool = $obj->mk_aliases( # create an alias to an existing
+ alias_name => 'method'); # method name
+
+ $clone = $obj->mk_clone; # create a clone of original
+ # object without data
+ $bool = $obj->mk_flush; # clean out all data
+
+ @list = $obj->ls_accessors; # retrieves a list of all
+ # accessors for this object
+
+ $bar = $obj->foo('bar'); # set 'foo' to 'bar'
+ $bar = $obj->foo(); # retrieve 'bar' again
+
+ $sub = $obj->can('foo'); # retrieve coderef for
+ # 'foo' accessor
+ $bar = $sub->('bar'); # set 'foo' via coderef
+ $bar = $sub->(); # retrieve 'bar' by coderef
+
+ ### using the object as base class
+ package My::Class;
+ use base 'Object::Accessor';
+
+ $obj = My::Class->new; # create base object
+ $bool = $obj->mk_accessors('foo'); # create accessors, etc...
+
+ ### make all attempted access to non-existant accessors fatal
+ ### (defaults to false)
+ $Object::Accessor::FATAL = 1;
+
+ ### enable debugging
+ $Object::Accessor::DEBUG = 1;
+
+ ### advanced usage -- callbacks
+ { my $obj = Object::Accessor->new('foo');
+ $obj->register_callback( sub { ... } );
+
+ $obj->foo( 1 ); # these calls invoke the callback you registered
+ $obj->foo() # which allows you to change the get/set
+ # behaviour and what is returned to the caller.
+ }
+
+ ### advanced usage -- lvalue attributes
+ { my $obj = Object::Accessor::Lvalue->new('foo');
+ print $obj->foo = 1; # will print 1
+ }
+
+ ### advanced usage -- scoped attribute values
+ { my $obj = Object::Accessor->new('foo');
+
+ $obj->foo( 1 );
+ print $obj->foo; # will print 1
+
+ ### bind the scope of the value of attribute 'foo'
+ ### to the scope of '$x' -- when $x goes out of
+ ### scope, 'foo's previous value will be restored
+ { $obj->foo( 2 => \my $x );
+ print $obj->foo, ' ', $x; # will print '2 2'
+ }
+ print $obj->foo; # will print 1
+ }
+
+
+=head1 DESCRIPTION
+
+C<Object::Accessor> provides an interface to create per object
+accessors (as opposed to per C<Class> accessors, as, for example,
+C<Class::Accessor> provides).
+
+You can choose to either subclass this module, and thus using its
+accessors on your own module, or to store an C<Object::Accessor>
+object inside your own object, and access the accessors from there.
+See the C<SYNOPSIS> for examples.
+
+=head1 METHODS
+
+=head2 $object = Object::Accessor->new( [ARGS] );
+
+Creates a new (and empty) C<Object::Accessor> object. This method is
+inheritable.
+
+Any arguments given to C<new> are passed straight to C<mk_accessors>.
+
+If you want to be able to assign to your accessors as if they
+were C<lvalue>s, you should create your object in the
+C<Object::Acccessor::Lvalue> namespace instead. See the section
+on C<LVALUE ACCESSORS> below.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+
+ $obj->mk_accessors( @_ ) if @_;
+
+ return $obj;
+}
+
+=head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP );
+
+Creates a list of accessors for this object (and C<NOT> for other ones
+in the same class!).
+Will not clobber existing data, so if an accessor already exists,
+requesting to create again is effectively a C<no-op>.
+
+When providing a C<hashref> as argument, rather than a normal list,
+you can specify a list of key/value pairs of accessors and their
+respective input validators. The validators can be anything that
+C<Params::Check>'s C<allow> function accepts. Please see its manpage
+for details.
+
+For example:
+
+ $object->mk_accessors( {
+ foo => qr/^\d+$/, # digits only
+ bar => [0,1], # booleans
+ zot => \&my_sub # a custom verification sub
+ } );
+
+Returns true on success, false on failure.
+
+Accessors that are called on an object, that do not exist return
+C<undef> by default, but you can make this a fatal error by setting the
+global variable C<$FATAL> to true. See the section on C<GLOBAL
+VARIABLES> for details.
+
+Note that you can bind the values of attributes to a scope. This allows
+you to C<temporarily> change a value of an attribute, and have it's
+original value restored up on the end of it's bound variable's scope;
+
+For example, in this snippet of code, the attribute C<foo> will
+temporarily be set to C<2>, until the end of the scope of C<$x>, at
+which point the original value of C<1> will be restored.
+
+ my $obj = Object::Accessor->new;
+
+ $obj->mk_accessors('foo');
+ $obj->foo( 1 );
+ print $obj->foo; # will print 1
+
+ ### bind the scope of the value of attribute 'foo'
+ ### to the scope of '$x' -- when $x goes out of
+ ### scope, 'foo' previous value will be restored
+ { $obj->foo( 2 => \my $x );
+ print $obj->foo, ' ', $x; # will print '2 2'
+ }
+ print $obj->foo; # will print 1
+
+
+Note that all accessors are read/write for everyone. See the C<TODO>
+section for details.
+
+=cut
+
+sub mk_accessors {
+ my $self = $_[0];
+ my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
+
+ ### first argument is a hashref, which means key/val pairs
+ ### as keys + allow handlers
+ for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
+
+ ### already created apparently
+ if( exists $self->{$acc} ) {
+ __PACKAGE__->___debug( "Accessor '$acc' already exists");
+ next;
+ }
+
+ __PACKAGE__->___debug( "Creating accessor '$acc'");
+
+ ### explicitly vivify it, so that exists works in ls_accessors()
+ $self->{$acc}->[VALUE] = undef;
+
+ ### set the allow handler only if one was specified
+ $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
+ }
+
+ return 1;
+}
+
+=head2 @list = $self->ls_accessors;
+
+Returns a list of accessors that are supported by the current object.
+The corresponding coderefs can be retrieved by passing this list one
+by one to the C<can> method.
+
+=cut
+
+sub ls_accessors {
+ ### metainformation is stored in the stringified
+ ### key of the object, so skip that when listing accessors
+ return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
+}
+
+=head2 $ref = $self->ls_allow(KEY)
+
+Returns the allow handler for the given key, which can be used with
+C<Params::Check>'s C<allow()> handler. If there was no allow handler
+specified, an allow handler that always returns true will be returned.
+
+=cut
+
+sub ls_allow {
+ my $self = shift;
+ my $key = shift or return;
+ return exists $self->{$key}->[ALLOW]
+ ? $self->{$key}->[ALLOW]
+ : sub { 1 };
+}
+
+=head2 $bool = $self->mk_aliases( alias => method, [alias2 => method2, ...] );
+
+Creates an alias for a given method name. For all intents and purposes,
+these two accessors are now identical for this object. This is akin to
+doing the following on the symbol table level:
+
+ *alias = *method
+
+This allows you to do the following:
+
+ $self->mk_accessors('foo');
+ $self->mk_aliases( bar => 'foo' );
+
+ $self->bar( 42 );
+ print $self->foo; # will print 42
+
+=cut
+
+sub mk_aliases {
+ my $self = shift;
+ my %aliases = @_;
+
+ while( my($alias, $method) = each %aliases ) {
+
+ ### already created apparently
+ if( exists $self->{$alias} ) {
+ __PACKAGE__->___debug( "Accessor '$alias' already exists");
+ next;
+ }
+
+ $self->___alias( $alias => $method );
+ }
+
+ return 1;
+}
+
+=head2 $clone = $self->mk_clone;
+
+Makes a clone of the current object, which will have the exact same
+accessors as the current object, but without the data stored in them.
+
+=cut
+
+### XXX this creates an object WITH allow handlers at all times.
+### even if the original didnt
+sub mk_clone {
+ my $self = $_[0];
+ my $class = ref $self;
+
+ my $clone = $class->new;
+
+ ### split out accessors with and without allow handlers, so we
+ ### don't install dummy allow handers (which makes O::A::lvalue
+ ### warn for example)
+ my %hash; my @list;
+ for my $acc ( $self->ls_accessors ) {
+ my $allow = $self->{$acc}->[ALLOW];
+ $allow ? $hash{$acc} = $allow : push @list, $acc;
+
+ ### is this an alias?
+ if( my $org = $self->{ $acc }->[ ALIAS ] ) {
+ $clone->___alias( $acc => $org );
+ }
+ }
+
+ ### copy the accessors from $self to $clone
+ $clone->mk_accessors( \%hash ) if %hash;
+ $clone->mk_accessors( @list ) if @list;
+
+ ### copy callbacks
+ #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
+ $clone->___callback( $self->___callback );
+
+ return $clone;
+}
+
+=head2 $bool = $self->mk_flush;
+
+Flushes all the data from the current object; all accessors will be
+set back to their default state of C<undef>.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub mk_flush {
+ my $self = $_[0];
+
+ # set each accessor's data to undef
+ $self->{$_}->[VALUE] = undef for $self->ls_accessors;
+
+ return 1;
+}
+
+=head2 $bool = $self->mk_verify;
+
+Checks if all values in the current object are in accordance with their
+own allow handler. Specifically useful to check if an empty initialised
+object has been filled with values satisfying their own allow criteria.
+
+=cut
+
+sub mk_verify {
+ my $self = $_[0];
+
+ my $fail;
+ for my $name ( $self->ls_accessors ) {
+ unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
+ my $val = defined $self->$name ? $self->$name : '<undef>';
+
+ __PACKAGE__->___error("'$name' ($val) is invalid");
+ $fail++;
+ }
+ }
+
+ return if $fail;
+ return 1;
+}
+
+=head2 $bool = $self->register_callback( sub { ... } );
+
+This method allows you to register a callback, that is invoked
+every time an accessor is called. This allows you to munge input
+data, access external data stores, etc.
+
+You are free to return whatever you wish. On a C<set> call, the
+data is even stored in the object.
+
+Below is an example of the use of a callback.
+
+ $object->some_method( "some_value" );
+
+ my $callback = sub {
+ my $self = shift; # the object
+ my $meth = shift; # "some_method"
+ my $val = shift; # ["some_value"]
+ # could be undef -- check 'exists';
+ # if scalar @$val is empty, it was a 'get'
+
+ # your code here
+
+ return $new_val; # the value you want to be set/returned
+ }
+
+To access the values stored in the object, circumventing the
+callback structure, you should use the C<___get> and C<___set> methods
+documented further down.
+
+=cut
+
+sub register_callback {
+ my $self = shift;
+ my $sub = shift or return;
+
+ ### use the memory address as key, it's not used EVER as an
+ ### accessor --kane
+ $self->___callback( $sub );
+
+ return 1;
+}
+
+
+=head2 $bool = $self->can( METHOD_NAME )
+
+This method overrides C<UNIVERAL::can> in order to provide coderefs to
+accessors which are loaded on demand. It will behave just like
+C<UNIVERSAL::can> where it can -- returning a class method if it exists,
+or a closure pointing to a valid accessor of this particular object.
+
+You can use it as follows:
+
+ $sub = $object->can('some_accessor'); # retrieve the coderef
+ $sub->('foo'); # 'some_accessor' now set
+ # to 'foo' for $object
+ $foo = $sub->(); # retrieve the contents
+ # of 'some_accessor'
+
+See the C<SYNOPSIS> for more examples.
+
+=cut
+
+### custom 'can' as UNIVERSAL::can ignores autoload
+sub can {
+ my($self, $method) = @_;
+
+ ### it's one of our regular methods
+ if( $self->UNIVERSAL::can($method) ) {
+ __PACKAGE__->___debug( "Can '$method' -- provided by package" );
+ return $self->UNIVERSAL::can($method);
+ }
+
+ ### it's an accessor we provide;
+ if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
+ __PACKAGE__->___debug( "Can '$method' -- provided by object" );
+ return sub { $self->$method(@_); }
+ }
+
+ ### we don't support it
+ __PACKAGE__->___debug( "Cannot '$method'" );
+ return;
+}
+
+### don't autoload this
+sub DESTROY { 1 };
+
+### use autoload so we can have per-object accessors,
+### not per class, as that is incorrect
+sub AUTOLOAD {
+ my $self = shift;
+ my($method) = ($AUTOLOAD =~ /([^:']+$)/);
+
+ my $val = $self->___autoload( $method, @_ ) or return;
+
+ return $val->[0];
+}
+
+sub ___autoload {
+ my $self = shift;
+ my $method = shift;
+ my $assign = scalar @_; # is this an assignment?
+
+ ### a method on our object
+ if( UNIVERSAL::isa( $self, 'HASH' ) ) {
+ if ( not exists $self->{$method} ) {
+ __PACKAGE__->___error("No such accessor '$method'", 1);
+ return;
+ }
+
+ ### a method on something else, die with a descriptive error;
+ } else {
+ local $FATAL = 1;
+ __PACKAGE__->___error(
+ "You called '$AUTOLOAD' on '$self' which was interpreted by ".
+ __PACKAGE__ . " as an object call. Did you mean to include ".
+ "'$method' from somewhere else?", 1 );
+ }
+
+ ### is this is an alias, redispatch to the original method
+ if( my $original = $self->{ $method }->[ALIAS] ) {
+ return $self->___autoload( $original, @_ );
+ }
+
+ ### assign?
+ my $val = $assign ? shift(@_) : $self->___get( $method );
+
+ if( $assign ) {
+
+ ### any binding?
+ if( $_[0] ) {
+ if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
+
+ ### tie the reference, so we get an object and
+ ### we can use it's going out of scope to restore
+ ### the old value
+ my $cur = $self->{$method}->[VALUE];
+
+ tie ${$_[0]}, __PACKAGE__ . '::TIE',
+ sub { $self->$method( $cur ) };
+
+ ${$_[0]} = $val;
+
+ } else {
+ __PACKAGE__->___error(
+ "Can not bind '$method' to anything but a SCALAR", 1
+ );
+ }
+ }
+
+ ### need to check the value?
+ if( exists $self->{$method}->[ALLOW] ) {
+
+ ### double assignment due to 'used only once' warnings
+ local $Params::Check::VERBOSE = 0;
+ local $Params::Check::VERBOSE = 0;
+
+ allow( $val, $self->{$method}->[ALLOW] ) or (
+ __PACKAGE__->___error(
+ "'$val' is an invalid value for '$method'", 1),
+ return
+ );
+ }
+ }
+
+ ### callbacks?
+ if( my $sub = $self->___callback ) {
+ $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
+
+ ### register the error
+ $self->___error( $@, 1 ), return if $@;
+ }
+
+ ### now we can actually assign it
+ if( $assign ) {
+ $self->___set( $method, $val ) or return;
+ }
+
+ return [$val];
+}
+
+=head2 $val = $self->___get( METHOD_NAME );
+
+Method to directly access the value of the given accessor in the
+object. It circumvents all calls to allow checks, callbakcs, etc.
+
+Use only if you C<Know What You Are Doing>! General usage for
+this functionality would be in your own custom callbacks.
+
+=cut
+
+### XXX O::A::lvalue is mirroring this behaviour! if this
+### changes, lvalue's autoload must be changed as well
+sub ___get {
+ my $self = shift;
+ my $method = shift or return;
+ return $self->{$method}->[VALUE];
+}
+
+=head2 $bool = $self->___set( METHOD_NAME => VALUE );
+
+Method to directly set the value of the given accessor in the
+object. It circumvents all calls to allow checks, callbakcs, etc.
+
+Use only if you C<Know What You Are Doing>! General usage for
+this functionality would be in your own custom callbacks.
+
+=cut
+
+sub ___set {
+ my $self = shift;
+ my $method = shift or return;
+
+ ### you didn't give us a value to set!
+ exists $_[0] or return;
+ my $val = shift;
+
+ ### if there's more arguments than $self, then
+ ### replace the method called by the accessor.
+ ### XXX implement rw vs ro accessors!
+ $self->{$method}->[VALUE] = $val;
+
+ return 1;
+}
+
+=head2 $bool = $self->___alias( ALIAS => METHOD );
+
+Method to directly alias one accessor to another for
+this object. It circumvents all sanity checks, etc.
+
+Use only if you C<Know What You Are Doing>!
+
+=cut
+
+sub ___alias {
+ my $self = shift;
+ my $alias = shift or return;
+ my $method = shift or return;
+
+ $self->{ $alias }->[ALIAS] = $method;
+
+ return 1;
+}
+
+sub ___debug {
+ return unless $DEBUG;
+
+ my $self = shift;
+ my $msg = shift;
+ my $lvl = shift || 0;
+
+ local $Carp::CarpLevel += 1;
+
+ carp($msg);
+}
+
+sub ___error {
+ my $self = shift;
+ my $msg = shift;
+ my $lvl = shift || 0;
+ local $Carp::CarpLevel += ($lvl + 1);
+ $FATAL ? croak($msg) : carp($msg);
+}
+
+### objects might be overloaded.. if so, we can't trust what "$self"
+### will return, which might get *really* painful.. so check for that
+### and get their unoverloaded stringval if needed.
+sub ___callback {
+ my $self = shift;
+ my $sub = shift;
+
+ my $mem = overload::Overloaded( $self )
+ ? overload::StrVal( $self )
+ : "$self";
+
+ $self->{$mem} = $sub if $sub;
+
+ return $self->{$mem};
+}
+
+=head1 LVALUE ACCESSORS
+
+C<Object::Accessor> supports C<lvalue> attributes as well. To enable
+these, you should create your objects in the designated namespace,
+C<Object::Accessor::Lvalue>. For example:
+
+ my $obj = Object::Accessor::Lvalue->new('foo');
+ $obj->foo += 1;
+ print $obj->foo;
+
+will actually print C<1> and work as expected. Since this is an
+optional feature, that's not desirable in all cases, we require
+you to explicitly use the C<Object::Accessor::Lvalue> class.
+
+Doing the same on the standard C<Object>>Accessor> class would
+generate the following code & errors:
+
+ my $obj = Object::Accessor->new('foo');
+ $obj->foo += 1;
+
+ Can't modify non-lvalue subroutine call
+
+Note that C<lvalue> support on C<AUTOLOAD> routines is a
+C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.
+
+=head2 CAVEATS
+
+=over 4
+
+=item * Allow handlers
+
+Due to the nature of C<lvalue subs>, we never get access to the
+value you are assigning, so we can not check it againt your allow
+handler. Allow handlers are therefor unsupported under C<lvalue>
+conditions.
+
+See C<perldoc perlsub> for details.
+
+=item * Callbacks
+
+Due to the nature of C<lvalue subs>, we never get access to the
+value you are assigning, so we can not check provide this value
+to your callback. Furthermore, we can not distinguish between
+a C<get> and a C<set> call. Callbacks are therefor unsupported
+under C<lvalue> conditions.
+
+See C<perldoc perlsub> for details.
+
+
+=cut
+
+{ package Object::Accessor::Lvalue;
+ use base 'Object::Accessor';
+ use strict;
+ use vars qw[$AUTOLOAD];
+
+ ### constants needed to access values from the objects
+ *VALUE = *Object::Accessor::VALUE;
+ *ALLOW = *Object::Accessor::ALLOW;
+
+ ### largely copied from O::A::Autoload
+ sub AUTOLOAD : lvalue {
+ my $self = shift;
+ my($method) = ($AUTOLOAD =~ /([^:']+$)/);
+
+ $self->___autoload( $method, @_ ) or return;
+
+ ### *dont* add return to it, or it won't be stored
+ ### see perldoc perlsub on lvalue subs
+ ### XXX can't use $self->___get( ... ), as we MUST have
+ ### the container that's used for the lvalue assign as
+ ### the last statement... :(
+ $self->{$method}->[ VALUE() ];
+ }
+
+ sub mk_accessors {
+ my $self = shift;
+ my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
+
+ $self->___error(
+ "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
+ ) if $is_hash;
+
+ return $self->SUPER::mk_accessors( @_ );
+ }
+
+ sub register_callback {
+ my $self = shift;
+ $self->___error(
+ "Callbacks are not supported for '". __PACKAGE__ ."' objects"
+ );
+ return;
+ }
+}
+
+
+### standard tie class for bound attributes
+{ package Object::Accessor::TIE;
+ use Tie::Scalar;
+ use Data::Dumper;
+ use base 'Tie::StdScalar';
+
+ my %local = ();
+
+ sub TIESCALAR {
+ my $class = shift;
+ my $sub = shift;
+ my $ref = undef;
+ my $obj = bless \$ref, $class;
+
+ ### store the restore sub
+ $local{ $obj } = $sub;
+ return $obj;
+ }
+
+ sub DESTROY {
+ my $tied = shift;
+ my $sub = delete $local{ $tied };
+
+ ### run the restore sub to set the old value back
+ return $sub->();
+ }
+}
+
+=back
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Object::Accessor::FATAL
+
+Set this variable to true to make all attempted access to non-existant
+accessors be fatal.
+This defaults to C<false>.
+
+=head2 $Object::Accessor::DEBUG
+
+Set this variable to enable debugging output.
+This defaults to C<false>.
+
+=head1 TODO
+
+=head2 Create read-only accessors
+
+Currently all accessors are read/write for everyone. Perhaps a future
+release should make it possible to have read-only accessors as well.
+
+=head1 CAVEATS
+
+If you use codereferences for your allow handlers, you will not be able
+to freeze the data structures using C<Storable>.
+
+Due to a bug in storable (until at least version 2.15), C<qr//> compiled
+regexes also don't de-serialize properly. Although this bug has been
+reported, you should be aware of this issue when serializing your objects.
+
+You can track the bug here:
+
+ http://rt.cpan.org/Ticket/Display.html?id=1827
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-object-accessor@rt.cpan.orgE<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Package/Constants.pm b/Master/tlpkg/tlperl/lib/Package/Constants.pm
new file mode 100644
index 00000000000..9ad6c62df47
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Package/Constants.pm
@@ -0,0 +1,106 @@
+package Package::Constants;
+
+use strict;
+use vars qw[$VERSION $DEBUG];
+
+$VERSION = '0.02';
+$DEBUG = 0;
+
+=head1 NAME
+
+Package::Constants - List all constants declared in a package
+
+=head1 SYNOPSIS
+
+ use Package::Constants;
+
+ ### list the names of all constants in a given package;
+ @const = Package::Constants->list( __PACKAGE__ );
+ @const = Package::Constants->list( 'main' );
+
+ ### enable debugging output
+ $Package::Constants::DEBUG = 1;
+
+=head1 DESCRIPTION
+
+C<Package::Constants> lists all the constants defined in a certain
+package. This can be useful for, among others, setting up an
+autogenerated C<@EXPORT/@EXPORT_OK> for a Constants.pm file.
+
+=head1 CLASS METHODS
+
+=head2 @const = Package::Constants->list( PACKAGE_NAME );
+
+Lists the names of all the constants defined in the provided package.
+
+=cut
+
+sub list {
+ my $class = shift;
+ my $pkg = shift;
+ return unless defined $pkg; # some joker might use '0' as a pkg...
+
+ _debug("Inspecting package '$pkg'");
+
+ my @rv;
+ { no strict 'refs';
+ my $stash = $pkg . '::';
+
+ for my $name (sort keys %$stash ) {
+
+ _debug( " Checking stash entry '$name'" );
+
+ ### is it a subentry?
+ my $sub = $pkg->can( $name );
+ next unless defined $sub;
+
+ _debug( " '$name' is a coderef" );
+
+ next unless defined prototype($sub) and
+ not length prototype($sub);
+
+ _debug( " '$name' is a constant" );
+ push @rv, $name;
+ }
+ }
+
+ return sort @rv;
+}
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Package::Constants::DEBUG
+
+When set to true, prints out debug information to STDERR about the
+package it is inspecting. Helps to identify issues when the results
+are not as you expect.
+
+Defaults to false.
+
+=cut
+
+sub _debug { warn "@_\n" if $DEBUG; }
+
+1;
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-package-constants@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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:
diff --git a/Master/tlpkg/tlperl/lib/Params/Check.pm b/Master/tlpkg/tlperl/lib/Params/Check.pm
new file mode 100644
index 00000000000..7348cbc0d7f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Params/Check.pm
@@ -0,0 +1,712 @@
+package Params::Check;
+
+use strict;
+
+use Carp qw[carp croak];
+use Locale::Maketext::Simple Style => 'gettext';
+
+use Data::Dumper;
+
+BEGIN {
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
+ $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
+ $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
+ $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
+ ];
+
+ @ISA = qw[ Exporter ];
+ @EXPORT_OK = qw[check allow last_error];
+
+ $VERSION = '0.26';
+ $VERBOSE = $^W ? 1 : 0;
+ $NO_DUPLICATES = 0;
+ $STRIP_LEADING_DASHES = 0;
+ $STRICT_TYPE = 0;
+ $ALLOW_UNKNOWN = 0;
+ $PRESERVE_CASE = 0;
+ $ONLY_ALLOW_DEFINED = 0;
+ $SANITY_CHECK_TEMPLATE = 1;
+ $WARNINGS_FATAL = 0;
+ $CALLER_DEPTH = 0;
+}
+
+my %known_keys = map { $_ => 1 }
+ qw| required allow default strict_type no_override
+ store defined |;
+
+=pod
+
+=head1 NAME
+
+Params::Check - A generic input parsing/checking mechanism.
+
+=head1 SYNOPSIS
+
+ use Params::Check qw[check allow last_error];
+
+ sub fill_personal_info {
+ my %hash = @_;
+ my $x;
+
+ my $tmpl = {
+ firstname => { required => 1, defined => 1 },
+ lastname => { required => 1, store => \$x },
+ gender => { required => 1,
+ allow => [qr/M/i, qr/F/i],
+ },
+ married => { allow => [0,1] },
+ age => { default => 21,
+ allow => qr/^\d+$/,
+ },
+
+ phone => { allow => [ sub { return 1 if /$valid_re/ },
+ '1-800-PERL' ]
+ },
+ id_list => { default => [],
+ strict_type => 1
+ },
+ employer => { default => 'NSA', no_override => 1 },
+ };
+
+ ### check() returns a hashref of parsed args on success ###
+ my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
+ or die qw[Could not parse arguments!];
+
+ ... other code here ...
+ }
+
+ my $ok = allow( $colour, [qw|blue green yellow|] );
+
+ my $error = Params::Check::last_error();
+
+
+=head1 DESCRIPTION
+
+Params::Check is a generic input parsing/checking mechanism.
+
+It allows you to validate input via a template. The only requirement
+is that the arguments must be named.
+
+Params::Check can do the following things for you:
+
+=over 4
+
+=item *
+
+Convert all keys to lowercase
+
+=item *
+
+Check if all required arguments have been provided
+
+=item *
+
+Set arguments that have not been provided to the default
+
+=item *
+
+Weed out arguments that are not supported and warn about them to the
+user
+
+=item *
+
+Validate the arguments given by the user based on strings, regexes,
+lists or even subroutines
+
+=item *
+
+Enforce type integrity if required
+
+=back
+
+Most of Params::Check's power comes from its template, which we'll
+discuss below:
+
+=head1 Template
+
+As you can see in the synopsis, based on your template, the arguments
+provided will be validated.
+
+The template can take a different set of rules per key that is used.
+
+The following rules are available:
+
+=over 4
+
+=item default
+
+This is the default value if none was provided by the user.
+This is also the type C<strict_type> will look at when checking type
+integrity (see below).
+
+=item required
+
+A boolean flag that indicates if this argument was a required
+argument. If marked as required and not provided, check() will fail.
+
+=item strict_type
+
+This does a C<ref()> check on the argument provided. The C<ref> of the
+argument must be the same as the C<ref> of the default value for this
+check to pass.
+
+This is very useful if you insist on taking an array reference as
+argument for example.
+
+=item defined
+
+If this template key is true, enforces that if this key is provided by
+user input, its value is C<defined>. This just means that the user is
+not allowed to pass C<undef> as a value for this key and is equivalent
+to:
+ allow => sub { defined $_[0] && OTHER TESTS }
+
+=item no_override
+
+This allows you to specify C<constants> in your template. ie, they
+keys that are not allowed to be altered by the user. It pretty much
+allows you to keep all your C<configurable> data in one place; the
+C<Params::Check> template.
+
+=item store
+
+This allows you to pass a reference to a scalar, in which the data
+will be stored:
+
+ my $x;
+ my $args = check(foo => { default => 1, store => \$x }, $input);
+
+This is basically shorthand for saying:
+
+ my $args = check( { foo => { default => 1 }, $input );
+ my $x = $args->{foo};
+
+You can alter the global variable $Params::Check::NO_DUPLICATES to
+control whether the C<store>'d key will still be present in your
+result set. See the L<Global Variables> section below.
+
+=item allow
+
+A set of criteria used to validate a particular piece of data if it
+has to adhere to particular rules.
+
+See the C<allow()> function for details.
+
+=back
+
+=head1 Functions
+
+=head2 check( \%tmpl, \%args, [$verbose] );
+
+This function is not exported by default, so you'll have to ask for it
+via:
+
+ use Params::Check qw[check];
+
+or use its fully qualified name instead.
+
+C<check> takes a list of arguments, as follows:
+
+=over 4
+
+=item Template
+
+This is a hashreference which contains a template as explained in the
+C<SYNOPSIS> and C<Template> section.
+
+=item Arguments
+
+This is a reference to a hash of named arguments which need checking.
+
+=item Verbose
+
+A boolean to indicate whether C<check> should be verbose and warn
+about what went wrong in a check or not.
+
+You can enable this program wide by setting the package variable
+C<$Params::Check::VERBOSE> to a true value. For details, see the
+section on C<Global Variables> below.
+
+=back
+
+C<check> will return when it fails, or a hashref with lowercase
+keys of parsed arguments when it succeeds.
+
+So a typical call to check would look like this:
+
+ my $parsed = check( \%template, \%arguments, $VERBOSE )
+ or warn q[Arguments could not be parsed!];
+
+A lot of the behaviour of C<check()> can be altered by setting
+package variables. See the section on C<Global Variables> for details
+on this.
+
+=cut
+
+sub check {
+ my ($utmpl, $href, $verbose) = @_;
+
+ ### did we get the arguments we need? ###
+ return if !$utmpl or !$href;
+
+ ### sensible defaults ###
+ $verbose ||= $VERBOSE || 0;
+
+ ### clear the current error string ###
+ _clear_error();
+
+ ### XXX what type of template is it? ###
+ ### { key => { } } ?
+ #if (ref $args eq 'HASH') {
+ # 1;
+ #}
+
+ ### clean up the template ###
+ my $args = _clean_up_args( $href ) or return;
+
+ ### sanity check + defaults + required keys set? ###
+ my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
+ or return;
+
+ ### deref only once ###
+ my %utmpl = %$utmpl;
+ my %args = %$args;
+ my %defs = %$defs;
+
+ ### flag to see if anything went wrong ###
+ my $wrong;
+
+ ### flag to see if we warned for anything, needed for warnings_fatal
+ my $warned;
+
+ for my $key (keys %args) {
+
+ ### you gave us this key, but it's not in the template ###
+ unless( $utmpl{$key} ) {
+
+ ### but we'll allow it anyway ###
+ if( $ALLOW_UNKNOWN ) {
+ $defs{$key} = $args{$key};
+
+ ### warn about the error ###
+ } else {
+ _store_error(
+ loc("Key '%1' is not a valid key for %2 provided by %3",
+ $key, _who_was_it(), _who_was_it(1)), $verbose);
+ $warned ||= 1;
+ }
+ next;
+ }
+
+ ### check if you're even allowed to override this key ###
+ if( $utmpl{$key}->{'no_override'} ) {
+ _store_error(
+ loc(q[You are not allowed to override key '%1'].
+ q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
+ $verbose
+ );
+ $warned ||= 1;
+ next;
+ }
+
+ ### copy of this keys template instructions, to save derefs ###
+ my %tmpl = %{$utmpl{$key}};
+
+ ### check if you were supposed to provide defined() values ###
+ if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
+ not defined $args{$key}
+ ) {
+ _store_error(loc(q|Key '%1' must be defined when passed|, $key),
+ $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if they should be of a strict type, and if it is ###
+ if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
+ (ref $args{$key} ne ref $tmpl{'default'})
+ ) {
+ _store_error(loc(q|Key '%1' needs to be of type '%2'|,
+ $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
+ $wrong ||= 1;
+ next;
+ }
+
+ ### check if we have an allow handler, to validate against ###
+ ### allow() will report its own errors ###
+ if( exists $tmpl{'allow'} and not do {
+ local $_ERROR_STRING;
+ allow( $args{$key}, $tmpl{'allow'} )
+ }
+ ) {
+ ### stringify the value in the error report -- we don't want dumps
+ ### of objects, but we do want to see *roughly* what we passed
+ _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
+ q|provided by %4|,
+ $key, "$args{$key}", _who_was_it(),
+ _who_was_it(1)), $verbose);
+ $wrong ||= 1;
+ next;
+ }
+
+ ### we got here, then all must be OK ###
+ $defs{$key} = $args{$key};
+
+ }
+
+ ### croak with the collected errors if there were errors and
+ ### we have the fatal flag toggled.
+ croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
+
+ ### done with our loop... if $wrong is set, somethign went wrong
+ ### and the user is already informed, just return...
+ return if $wrong;
+
+ ### check if we need to store any of the keys ###
+ ### can't do it before, because something may go wrong later,
+ ### leaving the user with a few set variables
+ for my $key (keys %defs) {
+ if( my $ref = $utmpl{$key}->{'store'} ) {
+ $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
+ }
+ }
+
+ return \%defs;
+}
+
+=head2 allow( $test_me, \@criteria );
+
+The function that handles the C<allow> key in the template is also
+available for independent use.
+
+The function takes as first argument a key to test against, and
+as second argument any form of criteria that are also allowed by
+the C<allow> key in the template.
+
+You can use the following types of values for allow:
+
+=over 4
+
+=item string
+
+The provided argument MUST be equal to the string for the validation
+to pass.
+
+=item regexp
+
+The provided argument MUST match the regular expression for the
+validation to pass.
+
+=item subroutine
+
+The provided subroutine MUST return true in order for the validation
+to pass and the argument accepted.
+
+(This is particularly useful for more complicated data).
+
+=item array ref
+
+The provided argument MUST equal one of the elements of the array
+ref for the validation to pass. An array ref can hold all the above
+values.
+
+=back
+
+It returns true if the key matched the criteria, or false otherwise.
+
+=cut
+
+sub allow {
+ ### use $_[0] and $_[1] since this is hot code... ###
+ #my ($val, $ref) = @_;
+
+ ### it's a regexp ###
+ if( ref $_[1] eq 'Regexp' ) {
+ local $^W; # silence warnings if $val is undef #
+ return if $_[0] !~ /$_[1]/;
+
+ ### it's a sub ###
+ } elsif ( ref $_[1] eq 'CODE' ) {
+ return unless $_[1]->( $_[0] );
+
+ ### it's an array ###
+ } elsif ( ref $_[1] eq 'ARRAY' ) {
+
+ ### loop over the elements, see if one of them says the
+ ### value is OK
+ ### also, short-cicruit when possible
+ for ( @{$_[1]} ) {
+ return 1 if allow( $_[0], $_ );
+ }
+
+ return;
+
+ ### fall back to a simple, but safe 'eq' ###
+ } else {
+ return unless _safe_eq( $_[0], $_[1] );
+ }
+
+ ### we got here, no failures ###
+ return 1;
+}
+
+### helper functions ###
+
+### clean up the template ###
+sub _clean_up_args {
+ ### don't even bother to loop, if there's nothing to clean up ###
+ return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
+
+ my %args = %{$_[0]};
+
+ ### keys are note aliased ###
+ for my $key (keys %args) {
+ my $org = $key;
+ $key = lc $key unless $PRESERVE_CASE;
+ $key =~ s/^-// if $STRIP_LEADING_DASHES;
+ $args{$key} = delete $args{$org} if $key ne $org;
+ }
+
+ ### return references so we always return 'true', even on empty
+ ### arguments
+ return \%args;
+}
+
+sub _sanity_check_and_defaults {
+ my %utmpl = %{$_[0]};
+ my %args = %{$_[1]};
+ my $verbose = $_[2];
+
+ my %defs; my $fail;
+ for my $key (keys %utmpl) {
+
+ ### check if required keys are provided
+ ### keys are now lower cased, unless preserve case was enabled
+ ### at which point, the utmpl keys must match, but that's the users
+ ### problem.
+ if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
+ _store_error(
+ loc(q|Required option '%1' is not provided for %2 by %3|,
+ $key, _who_was_it(1), _who_was_it(2)), $verbose );
+
+ ### mark the error ###
+ $fail++;
+ next;
+ }
+
+ ### next, set the default, make sure the key exists in %defs ###
+ $defs{$key} = $utmpl{$key}->{'default'}
+ if exists $utmpl{$key}->{'default'};
+
+ if( $SANITY_CHECK_TEMPLATE ) {
+ ### last, check if they provided any weird template keys
+ ### -- do this last so we don't always execute this code.
+ ### just a small optimization.
+ map { _store_error(
+ loc(q|Template type '%1' not supported [at key '%2']|,
+ $_, $key), 1, 1 );
+ } grep {
+ not $known_keys{$_}
+ } keys %{$utmpl{$key}};
+
+ ### make sure you passed a ref, otherwise, complain about it!
+ if ( exists $utmpl{$key}->{'store'} ) {
+ _store_error( loc(
+ q|Store variable for '%1' is not a reference!|, $key
+ ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
+ }
+ }
+ }
+
+ ### errors found ###
+ return if $fail;
+
+ ### return references so we always return 'true', even on empty
+ ### defaults
+ return \%defs;
+}
+
+sub _safe_eq {
+ ### only do a straight 'eq' if they're both defined ###
+ return defined($_[0]) && defined($_[1])
+ ? $_[0] eq $_[1]
+ : defined($_[0]) eq defined($_[1]);
+}
+
+sub _who_was_it {
+ my $level = $_[0] || 0;
+
+ return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
+}
+
+=head2 last_error()
+
+Returns a string containing all warnings and errors reported during
+the last time C<check> was called.
+
+This is useful if you want to report then some other way than
+C<carp>'ing when the verbose flag is on.
+
+It is exported upon request.
+
+=cut
+
+{ $_ERROR_STRING = '';
+
+ sub _store_error {
+ my($err, $verbose, $offset) = @_[0..2];
+ $verbose ||= 0;
+ $offset ||= 0;
+ my $level = 1 + $offset;
+
+ local $Carp::CarpLevel = $level;
+
+ carp $err if $verbose;
+
+ $_ERROR_STRING .= $err . "\n";
+ }
+
+ sub _clear_error {
+ $_ERROR_STRING = '';
+ }
+
+ sub last_error { $_ERROR_STRING }
+}
+
+1;
+
+=head1 Global Variables
+
+The behaviour of Params::Check can be altered by changing the
+following global variables:
+
+=head2 $Params::Check::VERBOSE
+
+This controls whether Params::Check will issue warnings and
+explanations as to why certain things may have failed.
+If you set it to 0, Params::Check will not output any warnings.
+
+The default is 1 when L<warnings> are enabled, 0 otherwise;
+
+=head2 $Params::Check::STRICT_TYPE
+
+This works like the C<strict_type> option you can pass to C<check>,
+which will turn on C<strict_type> globally for all calls to C<check>.
+
+The default is 0;
+
+=head2 $Params::Check::ALLOW_UNKNOWN
+
+If you set this flag, unknown options will still be present in the
+return value, rather than filtered out. This is useful if your
+subroutine is only interested in a few arguments, and wants to pass
+the rest on blindly to perhaps another subroutine.
+
+The default is 0;
+
+=head2 $Params::Check::STRIP_LEADING_DASHES
+
+If you set this flag, all keys passed in the following manner:
+
+ function( -key => 'val' );
+
+will have their leading dashes stripped.
+
+=head2 $Params::Check::NO_DUPLICATES
+
+If set to true, all keys in the template that are marked as to be
+stored in a scalar, will also be removed from the result set.
+
+Default is false, meaning that when you use C<store> as a template
+key, C<check> will put it both in the scalar you supplied, as well as
+in the hashref it returns.
+
+=head2 $Params::Check::PRESERVE_CASE
+
+If set to true, L<Params::Check> will no longer convert all keys from
+the user input to lowercase, but instead expect them to be in the
+case the template provided. This is useful when you want to use
+similar keys with different casing in your templates.
+
+Understand that this removes the case-insensitivy feature of this
+module.
+
+Default is 0;
+
+=head2 $Params::Check::ONLY_ALLOW_DEFINED
+
+If set to true, L<Params::Check> will require all values passed to be
+C<defined>. If you wish to enable this on a 'per key' basis, use the
+template option C<defined> instead.
+
+Default is 0;
+
+=head2 $Params::Check::SANITY_CHECK_TEMPLATE
+
+If set to true, L<Params::Check> will sanity check templates, validating
+for errors and unknown keys. Although very useful for debugging, this
+can be somewhat slow in hot-code and large loops.
+
+To disable this check, set this variable to C<false>.
+
+Default is 1;
+
+=head2 $Params::Check::WARNINGS_FATAL
+
+If set to true, L<Params::Check> will C<croak> when an error during
+template validation occurs, rather than return C<false>.
+
+Default is 0;
+
+=head2 $Params::Check::CALLER_DEPTH
+
+This global modifies the argument given to C<caller()> by
+C<Params::Check::check()> and is useful if you have a custom wrapper
+function around C<Params::Check::check()>. The value must be an
+integer, indicating the number of wrapper functions inserted between
+the real function call and C<Params::Check::check()>.
+
+Example wrapper function, using a custom stacktrace:
+
+ sub check {
+ my ($template, $args_in) = @_;
+
+ local $Params::Check::WARNINGS_FATAL = 1;
+ local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
+ my $args_out = Params::Check::check($template, $args_in);
+
+ my_stacktrace(Params::Check::last_error) unless $args_out;
+
+ return $args_out;
+ }
+
+Default is 0;
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 Acknowledgements
+
+Thanks to Richard Soderberg for his performance improvements.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2003,2004 Jos Boumans E<lt>kane@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.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm b/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm
new file mode 100644
index 00000000000..e7d585170b1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm
@@ -0,0 +1,437 @@
+package Parse::CPAN::Meta;
+
+use strict;
+use Carp 'croak';
+
+# UTF Support?
+sub HAVE_UTF8 () { $] >= 5.007003 }
+BEGIN {
+ if ( HAVE_UTF8 ) {
+ # The string eval helps hide this from Test::MinimumVersion
+ eval "require utf8;";
+ die "Failed to load UTF-8 support" if $@;
+ }
+
+ # Class structure
+ require 5.004;
+ require Exporter;
+ $Parse::CPAN::Meta::VERSION = '1.40';
+ @Parse::CPAN::Meta::ISA = qw{ Exporter };
+ @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
+}
+
+# Prototypes
+sub LoadFile ($);
+sub Load ($);
+sub _scalar ($$$);
+sub _array ($$$);
+sub _hash ($$$);
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+
+
+
+
+#####################################################################
+# Implementation
+
+# Create an object from a file
+sub LoadFile ($) {
+ # Check the file
+ my $file = shift;
+ croak('You did not specify a file name') unless $file;
+ croak( "File '$file' does not exist" ) unless -e $file;
+ croak( "'$file' is a directory, not a file" ) unless -f _;
+ croak( "Insufficient permissions to read '$file'" ) unless -r _;
+
+ # Slurp in the file
+ local $/ = undef;
+ local *CFG;
+ unless ( open( CFG, $file ) ) {
+ croak("Failed to open file '$file': $!");
+ }
+ my $yaml = <CFG>;
+ unless ( close(CFG) ) {
+ croak("Failed to close file '$file': $!");
+ }
+
+ # Hand off to the actual parser
+ Load( $yaml );
+}
+
+# Parse a document from a string.
+# Doing checks on $_[0] prevents us having to do a string copy.
+sub Load ($) {
+ my $string = $_[0];
+ unless ( defined $string ) {
+ croak("Did not provide a string to load");
+ }
+
+ # Byte order marks
+ if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
+ croak("Stream has a non UTF-8 Unicode Byte Order Mark");
+ } else {
+ # Strip UTF-8 bom if found, we'll just ignore it
+ $string =~ s/^\357\273\277//;
+ }
+
+ # Try to decode as utf8
+ utf8::decode($string) if HAVE_UTF8;
+
+ # Check for some special cases
+ return () unless length $string;
+ unless ( $string =~ /[\012\015]+\z/ ) {
+ croak("Stream does not end with newline character");
+ }
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
+
+ # A nibbling parser
+ my @documents = ();
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @documents, _scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @documents, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+
+ } elsif ( $lines[0] =~ /^\s*\-/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @documents, $document;
+ _array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @documents, $document;
+ _hash( $document, [ length($1) ], \@lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines[0]'");
+ }
+ }
+
+ if ( wantarray ) {
+ return @documents;
+ } else {
+ return $documents[-1];
+ }
+}
+
+# Deparse a scalar string to the actual scalar
+sub _scalar ($$$) {
+ my ($string, $indent, $lines) = @_;
+
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Quotes
+ if ( $string =~ /^\'(.*?)\'\z/ ) {
+ return '' unless defined $1;
+ $string = $1;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+ }
+ if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
+ # Reusing the variable is a little ugly,
+ # but avoids a new variable and a string copy.
+ $string = $1;
+ $string =~ s/\\"/"/g;
+ $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
+ return $string;
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ # Regular unquoted string
+ return $string unless $string =~ /^[>|]/;
+
+ # Error
+ croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+}
+
+# Parse an array
+sub _array ($$$) {
+ my ($array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, _scalar( "$2", [ @$indent, undef ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ _array( $array->[-1], [ @$indent, $indent2 ], $lines );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ _hash( $array->[-1], [ @$indent, length("$1") ], $lines );
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ }
+
+ return 1;
+}
+
+# Parse an array
+sub _hash ($$$) {
+ my ($hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
+ }
+
+ # Get the key
+ unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
+ if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
+ croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
+ }
+ croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
+ }
+ my $key = $1;
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ _array( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ _hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ }
+ }
+ }
+ }
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files
+
+=head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ rootproperty: blah
+ section:
+ one: two
+ three: four
+ Foo: Bar
+ empty: ~
+
+
+
+ #############################################
+ # In your program
+
+ use Parse::CPAN::Meta;
+
+ # Create a YAML file
+ my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' );
+
+ # Reading properties
+ my $root = $yaml[0]->{rootproperty};
+ my $one = $yaml[0]->{section}->{one};
+ my $Foo = $yaml[0]->{section}->{Foo};
+
+=head1 DESCRIPTION
+
+B<Parse::CPAN::Meta> is a parser for F<META.yml> files, based on the
+parser half of L<YAML::Tiny>.
+
+It supports a basic subset of the full YAML specification, enough to
+implement parsing of typical F<META.yml> files, and other similarly simple
+YAML files.
+
+If you need something with more power, move up to a full YAML parser such
+as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>.
+
+B<Parse::CPAN::Meta> provides a very simply API of only two functions,
+based on the YAML functions of the same name. Wherever possible,
+identical calling semantics are used.
+
+All error reporting is done with exceptions (die'ing).
+
+=head1 FUNCTIONS
+
+For maintenance clarity, no functions are exported.
+
+=head2 Load
+
+ my @yaml = Load( $string );
+
+Parses a string containing a valid YAML stream into a list of Perl data
+structures.
+
+=head2 LoadFile
+
+ my @yaml = LoadFile( 'META.yml' );
+
+Reads the YAML stream from a file instead of a string.
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta>
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/>
+
+=head1 COPYRIGHT
+
+Copyright 2006 - 2009 Adam Kennedy.
+
+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.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/PerlIO/encoding.pm b/Master/tlpkg/tlperl/lib/PerlIO/encoding.pm
new file mode 100644
index 00000000000..4b446703229
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/PerlIO/encoding.pm
@@ -0,0 +1,53 @@
+package PerlIO::encoding;
+
+use strict;
+our $VERSION = '0.12';
+our $DEBUG = 0;
+$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
+
+#
+# Equivalent of this is done in encoding.xs - do not uncomment.
+#
+# use Encode ();
+
+use XSLoader ();
+XSLoader::load(__PACKAGE__, $VERSION);
+
+our $fallback =
+ Encode::PERLQQ()|Encode::WARN_ON_ERR()|Encode::STOP_AT_PARTIAL();
+
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::encoding - encoding layer
+
+=head1 SYNOPSIS
+
+ use PerlIO::encoding;
+
+ open($f, "<:encoding(foo)", "infoo");
+ open($f, ">:encoding(bar)", "outbar");
+
+ use Encode qw(:fallbacks);
+ $PerlIO::encoding::fallback = FB_PERLQQ;
+
+=head1 DESCRIPTION
+
+This PerlIO layer opens a filehandle with a transparent encoding filter.
+
+On input, it converts the bytes expected to be in the specified
+character set and encoding to Perl string data (Unicode and
+Perl's internal Unicode encoding, UTF-8). On output, it converts
+Perl string data into the specified character set and encoding.
+
+When the layer is pushed, the current value of C<$PerlIO::encoding::fallback>
+is saved and used as the CHECK argument when calling the Encode methods
+encode() and decode().
+
+=head1 SEE ALSO
+
+L<open>, L<Encode>, L<perlfunc/binmode>, L<perluniintro>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/PerlIO/scalar.pm b/Master/tlpkg/tlperl/lib/PerlIO/scalar.pm
new file mode 100644
index 00000000000..f9e4368d7e5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/PerlIO/scalar.pm
@@ -0,0 +1,41 @@
+package PerlIO::scalar;
+our $VERSION = '0.08';
+use XSLoader ();
+XSLoader::load 'PerlIO::scalar';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::scalar - in-memory IO, scalar IO
+
+=head1 SYNOPSIS
+
+ my $scalar = '';
+ ...
+ open my $fh, "<", \$scalar or die;
+ open my $fh, ">", \$scalar or die;
+ open my $fh, ">>", \$scalar or die;
+
+or
+
+ my $scalar = '';
+ ...
+ open my $fh, "<:scalar", \$scalar or die;
+ open my $fh, ">:scalar", \$scalar or die;
+ open my $fh, ">>:scalar", \$scalar or die;
+
+=head1 DESCRIPTION
+
+A filehandle is opened but the file operations are performed "in-memory"
+on a scalar variable. All the normal file operations can be performed
+on the handle. The scalar is considered a stream of bytes. Currently
+fileno($fh) returns -1.
+
+=head1 IMPLEMENTATION NOTE
+
+C<PerlIO::scalar> only exists to use XSLoader to load C code that
+provides support for treating a scalar as an "in memory" file.
+One does not need to explicitly C<use PerlIO::scalar>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/PerlIO/via.pm b/Master/tlpkg/tlperl/lib/PerlIO/via.pm
new file mode 100644
index 00000000000..077f0d17f90
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/PerlIO/via.pm
@@ -0,0 +1,243 @@
+package PerlIO::via;
+our $VERSION = '0.09';
+use XSLoader ();
+XSLoader::load 'PerlIO::via';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::via - Helper class for PerlIO layers implemented in perl
+
+=head1 SYNOPSIS
+
+ use PerlIO::via::Layer;
+ open($fh,"<:via(Layer)",...);
+
+ use Some::Other::Package;
+ open($fh,">:via(Some::Other::Package)",...);
+
+=head1 DESCRIPTION
+
+The PerlIO::via module allows you to develop PerlIO layers in Perl, without
+having to go into the nitty gritty of programming C with XS as the interface
+to Perl.
+
+One example module, L<PerlIO::via::QuotedPrint>, is included with Perl
+5.8.0, and more example modules are available from CPAN, such as
+L<PerlIO::via::StripHTML> and L<PerlIO::via::Base64>. The
+PerlIO::via::StripHTML module for instance, allows you to say:
+
+ use PerlIO::via::StripHTML;
+ open( my $fh, "<:via(StripHTML)", "index.html" );
+ my @line = <$fh>;
+
+to obtain the text of an HTML-file in an array with all the HTML-tags
+automagically removed.
+
+Please note that if the layer is created in the PerlIO::via:: namespace, it
+does B<not> have to be fully qualified. The PerlIO::via module will prefix
+the PerlIO::via:: namespace if the specified modulename does not exist as a
+fully qualified module name.
+
+=head1 EXPECTED METHODS
+
+To create a Perl module that implements a PerlIO layer in Perl (as opposed to
+in C using XS as the interface to Perl), you need to supply some of the
+following subroutines. It is recommended to create these Perl modules in the
+PerlIO::via:: namespace, so that they can easily be located on CPAN and use
+the default namespace feature of the PerlIO::via module itself.
+
+Please note that this is an area of recent development in Perl and that the
+interface described here is therefore still subject to change (and hopefully
+will have better documentation and more examples).
+
+In the method descriptions below I<$fh> will be
+a reference to a glob which can be treated as a perl file handle.
+It refers to the layer below. I<$fh> is not passed if the layer
+is at the bottom of the stack, for this reason and to maintain
+some level of "compatibility" with TIEHANDLE classes it is passed last.
+
+=over 4
+
+=item $class->PUSHED([$mode,[$fh]])
+
+Should return an object or the class, or -1 on failure. (Compare
+TIEHANDLE.) The arguments are an optional mode string ("r", "w",
+"w+", ...) and a filehandle for the PerlIO layer below. Mandatory.
+
+When the layer is pushed as part of an C<open> call, C<PUSHED> will be called
+I<before> the actual open occurs, whether that be via C<OPEN>, C<SYSOPEN>,
+C<FDOPEN> or by letting a lower layer do the open.
+
+=item $obj->POPPED([$fh])
+
+Optional - called when the layer is about to be removed.
+
+=item $obj->UTF8($bellowFlag,[$fh])
+
+Optional - if present it will be called immediately after PUSHED has
+returned. It should return a true value if the layer expects data to be
+UTF-8 encoded. If it returns true, the result is as if the caller had done
+
+ ":via(YourClass):utf8"
+
+If not present or if it returns false, then the stream is left with
+the UTF-8 flag clear.
+The I<$bellowFlag> argument will be true if there is a layer below
+and that layer was expecting UTF-8.
+
+=item $obj->OPEN($path,$mode,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called for normal opens after the layer is pushed.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->BINMODE([$fh])
+
+Optional - if not present the layer is popped on binmode($fh) or when C<:raw>
+is pushed. If present it should return 0 on success, -1 on error, or undef
+to pop the layer.
+
+=item $obj->FDOPEN($fd,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for opens which pass
+a numeric file descriptor.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->SYSOPEN($path,$imode,$perm,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for sysopen style opens
+which pass a numeric mode and permissions.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->FILENO($fh)
+
+Returns a numeric value for a Unix-like file descriptor. Returns -1 if
+there isn't one. Optional. Default is fileno($fh).
+
+=item $obj->READ($buffer,$len,$fh)
+
+Returns the number of octets placed in $buffer (must be less than or
+equal to $len). Optional. Default is to use FILL instead.
+
+=item $obj->WRITE($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully written.
+
+=item $obj->FILL($fh)
+
+Should return a string to be placed in the buffer. Optional. If not
+provided, must provide READ or reject handles open for reading in
+PUSHED.
+
+=item $obj->CLOSE($fh)
+
+Should return 0 on success, -1 on error.
+Optional.
+
+=item $obj->SEEK($posn,$whence,$fh)
+
+Should return 0 on success, -1 on error.
+Optional. Default is to fail, but that is likely to be changed
+in future.
+
+=item $obj->TELL($fh)
+
+Returns file position.
+Optional. Default to be determined.
+
+=item $obj->UNREAD($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully
+saved to be returned on future FILL/READ calls. Optional. Default is
+to push data into a temporary layer above this one.
+
+=item $obj->FLUSH($fh)
+
+Flush any buffered write data. May possibly be called on readable
+handles too. Should return 0 on success, -1 on error.
+
+=item $obj->SETLINEBUF($fh)
+
+Optional. No return.
+
+=item $obj->CLEARERR($fh)
+
+Optional. No return.
+
+=item $obj->ERROR($fh)
+
+Optional. Returns error state. Default is no error until a mechanism
+to signal error (die?) is worked out.
+
+=item $obj->EOF($fh)
+
+Optional. Returns end-of-file state. Default is a function of the return
+value of FILL or READ.
+
+=back
+
+=head1 EXAMPLES
+
+Check the PerlIO::via:: namespace on CPAN for examples of PerlIO layers
+implemented in Perl. To give you an idea how simple the implementation of
+a PerlIO layer can look, a simple example is included here.
+
+=head2 Example - a Hexadecimal Handle
+
+Given the following module, PerlIO::via::Hex :
+
+ package PerlIO::via::Hex;
+
+ sub PUSHED
+ {
+ my ($class,$mode,$fh) = @_;
+ # When writing we buffer the data
+ my $buf = '';
+ return bless \$buf,$class;
+ }
+
+ sub FILL
+ {
+ my ($obj,$fh) = @_;
+ my $line = <$fh>;
+ return (defined $line) ? pack("H*", $line) : undef;
+ }
+
+ sub WRITE
+ {
+ my ($obj,$buf,$fh) = @_;
+ $$obj .= unpack("H*", $buf);
+ return length($buf);
+ }
+
+ sub FLUSH
+ {
+ my ($obj,$fh) = @_;
+ print $fh $$obj or return -1;
+ $$obj = '';
+ return 0;
+ }
+
+ 1;
+
+The following code opens up an output handle that will convert any
+output to a hexadecimal dump of the output bytes: for example "A" will
+be converted to "41" (on ASCII-based machines, on EBCDIC platforms
+the "A" will become "c1")
+
+ use PerlIO::via::Hex;
+ open(my $fh, ">:via(Hex)", "foo.hex");
+
+and the following code will read the hexdump in and convert it
+on the fly back into bytes:
+
+ open(my $fh, "<:via(Hex)", "foo.hex");
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm b/Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm
new file mode 100644
index 00000000000..2434191f091
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm
@@ -0,0 +1,94 @@
+package PerlIO::via::QuotedPrint;
+
+# Set the version info
+# Make sure we do things by the book from now on
+
+$VERSION = '0.06';
+use strict;
+
+# Make sure the encoding/decoding stuff is available
+
+use MIME::QuotedPrint (); # no need to pollute this namespace
+
+# Satisfy -require-
+
+1;
+
+#-----------------------------------------------------------------------
+# IN: 1 class to bless with
+# 2 mode string (ignored)
+# 3 file handle of PerlIO layer below (ignored)
+# OUT: 1 blessed object
+
+sub PUSHED { bless \*PUSHED,$_[0] } #PUSHED
+
+#-----------------------------------------------------------------------
+# IN: 1 instantiated object (ignored)
+# 2 handle to read from
+# OUT: 1 decoded string
+
+sub FILL {
+
+# Read the line from the handle
+# Decode if there is something decode and return result or signal eof
+
+ my $line = readline( $_[1] );
+ (defined $line) ? MIME::QuotedPrint::decode_qp( $line ) : undef;
+} #FILL
+
+#-----------------------------------------------------------------------
+# IN: 1 instantiated object (ignored)
+# 2 buffer to be written
+# 3 handle to write to
+# OUT: 1 number of bytes written
+
+sub WRITE {
+
+# Encode whatever needs to be encoded and write to handle: indicate result
+
+ (print {$_[2]} MIME::QuotedPrint::encode_qp($_[1])) ? length($_[1]) : -1;
+} #WRITE
+
+__END__
+
+=head1 NAME
+
+PerlIO::via::QuotedPrint - PerlIO layer for quoted-printable strings
+
+=head1 SYNOPSIS
+
+ use PerlIO::via::QuotedPrint;
+
+ open( my $in,'<:via(QuotedPrint)','file.qp' )
+ or die "Can't open file.qp for reading: $!\n";
+
+ open( my $out,'>:via(QuotedPrint)','file.qp' )
+ or die "Can't open file.qp for writing: $!\n";
+
+=head1 DESCRIPTION
+
+This module implements a PerlIO layer that works on files encoded in the
+quoted-printable format. It will decode from quoted-printable while reading
+from a handle, and it will encode as quoted-printable while writing to a handle.
+
+=head1 REQUIRED MODULES
+
+ MIME::QuotedPrint (any)
+
+=head1 SEE ALSO
+
+L<PerlIO::via>, L<MIME::QuotedPrint>, L<PerlIO::via::Base64>,
+L<PerlIO::via::MD5>, L<PerlIO::via::StripHTML>, L<PerlIO::via::Rotate>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Based on example that was initially added to MIME::QuotedPrint.pm for the
+5.8.0 distribution of Perl.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2003 Elizabeth Mattijsen. All rights reserved. This
+library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Scalar/Util.pm b/Master/tlpkg/tlperl/lib/Scalar/Util.pm
new file mode 100644
index 00000000000..24f146f2b3f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Scalar/Util.pm
@@ -0,0 +1,283 @@
+# Scalar::Util.pm
+#
+# Copyright (c) 1997-2007 Graham Barr <gbarr@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 Scalar::Util;
+
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL);
+require Exporter;
+require List::Util; # List::Util loads the XS
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
+$VERSION = "1.22";
+$VERSION = eval $VERSION;
+
+unless (defined &dualvar) {
+ # Load Pure Perl version if XS not loaded
+ require Scalar::Util::PP;
+ Scalar::Util::PP->import;
+ push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
+}
+
+sub export_fail {
+ if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded
+ my $pat = join("|", @EXPORT_FAIL);
+ if (my ($err) = grep { /^($pat)$/ } @_ ) {
+ require Carp;
+ Carp::croak("$err is only available with the XS version of Scalar::Util");
+ }
+ }
+
+ if (grep { /^(weaken|isweak)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Weak references are not implemented in the version of perl");
+ }
+
+ if (grep { /^(isvstring)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Vstrings are not implemented in the version of perl");
+ }
+
+ @_;
+}
+
+sub openhandle ($) {
+ my $fh = shift;
+ my $rt = reftype($fh) || '';
+
+ return defined(fileno($fh)) ? $fh : undef
+ if $rt eq 'IO';
+
+ if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
+ $fh = \(my $tmp=$fh);
+ }
+ elsif ($rt ne 'GLOB') {
+ return undef;
+ }
+
+ (tied(*$fh) or defined(fileno($fh)))
+ ? $fh : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scalar::Util - A selection of general-utility scalar subroutines
+
+=head1 SYNOPSIS
+
+ use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
+ weaken isvstring looks_like_number set_prototype);
+ # and other useful utils appearing below
+
+=head1 DESCRIPTION
+
+C<Scalar::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<Scalar::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item blessed EXPR
+
+If EXPR evaluates to a blessed reference the name of the package
+that it is blessed into is returned. Otherwise C<undef> is returned.
+
+ $scalar = "foo";
+ $class = blessed $scalar; # undef
+
+ $ref = [];
+ $class = blessed $ref; # undef
+
+ $obj = bless [], "Foo";
+ $class = blessed $obj; # "Foo"
+
+=item dualvar NUM, STRING
+
+Returns a scalar that has the value NUM in a numeric context and the
+value STRING in a string context.
+
+ $foo = dualvar 10, "Hello";
+ $num = $foo + 2; # 12
+ $str = $foo . " world"; # Hello world
+
+=item isvstring EXPR
+
+If EXPR is a scalar which was coded as a vstring the result is true.
+
+ $vs = v49.46.48;
+ $fmt = isvstring($vs) ? "%vd" : "%s"; #true
+ printf($fmt,$vs);
+
+=item isweak EXPR
+
+If EXPR is a scalar which is a weak reference the result is true.
+
+ $ref = \$foo;
+ $weak = isweak($ref); # false
+ weaken($ref);
+ $weak = isweak($ref); # true
+
+B<NOTE>: Copying a weak reference creates a normal, strong, reference.
+
+ $copy = $ref;
+ $weak = isweak($copy); # false
+
+=item looks_like_number EXPR
+
+Returns true if perl thinks EXPR is a number. See
+L<perlapi/looks_like_number>.
+
+=item openhandle FH
+
+Returns FH if FH may be used as a filehandle and is open, or FH is a tied
+handle. Otherwise C<undef> is returned.
+
+ $fh = openhandle(*STDIN); # \*STDIN
+ $fh = openhandle(\*STDIN); # \*STDIN
+ $fh = openhandle(*NOTOPEN); # undef
+ $fh = openhandle("scalar"); # undef
+
+=item readonly SCALAR
+
+Returns true if SCALAR is readonly.
+
+ sub foo { readonly($_[0]) }
+
+ $readonly = foo($bar); # false
+ $readonly = foo(0); # true
+
+=item refaddr EXPR
+
+If EXPR evaluates to a reference the internal memory address of
+the referenced value is returned. Otherwise C<undef> is returned.
+
+ $addr = refaddr "string"; # undef
+ $addr = refaddr \$var; # eg 12345678
+ $addr = refaddr []; # eg 23456784
+
+ $obj = bless {}, "Foo";
+ $addr = refaddr $obj; # eg 88123488
+
+=item reftype EXPR
+
+If EXPR evaluates to a reference the type of the variable referenced
+is returned. Otherwise C<undef> is returned.
+
+ $type = reftype "string"; # undef
+ $type = reftype \$var; # SCALAR
+ $type = reftype []; # ARRAY
+
+ $obj = bless {}, "Foo";
+ $type = reftype $obj; # HASH
+
+=item set_prototype CODEREF, PROTOTYPE
+
+Sets the prototype of the given function, or deletes it if PROTOTYPE is
+undef. Returns the CODEREF.
+
+ set_prototype \&foo, '$$';
+
+=item tainted EXPR
+
+Return true if the result of EXPR is tainted
+
+ $taint = tainted("constant"); # false
+ $taint = tainted($ENV{PWD}); # true if running under -T
+
+=item weaken REF
+
+REF will be turned into a weak reference. This means that it will not
+hold a reference count on the object it references. Also when the reference
+count on that object reaches zero, REF will be set to undef.
+
+This is useful for keeping copies of references , but you don't want to
+prevent the object being DESTROY-ed at its usual time.
+
+ {
+ my $var;
+ $ref = \$var;
+ weaken($ref); # Make $ref a weak reference
+ }
+ # $ref is now undef
+
+Note that if you take a copy of a scalar with a weakened reference,
+the copy will be a strong reference.
+
+ my $var;
+ my $foo = \$var;
+ weaken($foo); # Make $foo a weak reference
+ my $bar = $foo; # $bar is now a strong reference
+
+This may be less obvious in other situations, such as C<grep()>, for instance
+when grepping through a list of weakened references to objects that may have
+been destroyed already:
+
+ @object = grep { defined } @object;
+
+This will indeed remove all references to destroyed objects, but the remaining
+references to objects will be strong, causing the remaining objects to never
+be destroyed because there is now always a strong reference to them in the
+@object array.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Module use may give one of the following errors during import.
+
+=over
+
+=item Weak references are not implemented in the version of perl
+
+The version of perl that you are using does not implement weak references, to use
+C<isweak> or C<weaken> you will need to use a newer release of perl.
+
+=item Vstrings are not implemented in the version of perl
+
+The version of perl that you are using does not implement Vstrings, to use
+C<isvstring> you will need to use a newer release of perl.
+
+=item C<NAME> is only available with the XS version of Scalar::Util
+
+C<Scalar::Util> contains both perl and C implementations of many of its functions
+so that those without access to a C compiler may still use it. However some of the functions
+are only available when a C compiler was available to compile the XS version of the extension.
+
+At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
+
+=back
+
+=head1 KNOWN BUGS
+
+There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
+show up as tests 8 and 9 of dualvar.t failing
+
+=head1 SEE ALSO
+
+L<List::Util>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2007 Graham Barr <gbarr@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.
+
+Except weaken and isweak which are
+
+Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm b/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm
new file mode 100644
index 00000000000..e94fe86f21c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm
@@ -0,0 +1,109 @@
+# Scalar::Util::PP.pm
+#
+# Copyright (c) 1997-2009 Graham Barr <gbarr@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.
+#
+# This module is normally only loaded if the XS module is not available
+
+package Scalar::Util::PP;
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT $VERSION $recurse);
+require Exporter;
+use B qw(svref_2object);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number);
+$VERSION = "1.22";
+$VERSION = eval $VERSION;
+
+sub blessed ($) {
+ return undef unless length(ref($_[0]));
+ my $b = svref_2object($_[0]);
+ return undef unless $b->isa('B::PVMG');
+ my $s = $b->SvSTASH;
+ return $s->isa('B::HV') ? $s->NAME : undef;
+}
+
+sub refaddr($) {
+ return undef unless length(ref($_[0]));
+
+ my $addr;
+ if(defined(my $pkg = blessed($_[0]))) {
+ $addr .= bless $_[0], 'Scalar::Util::Fake';
+ bless $_[0], $pkg;
+ }
+ else {
+ $addr .= $_[0]
+ }
+
+ $addr =~ /0x(\w+)/;
+ local $^W;
+ hex($1);
+}
+
+{
+ my %tmap = qw(
+ B::HV HASH
+ B::AV ARRAY
+ B::CV CODE
+ B::IO IO
+ B::NULL SCALAR
+ B::NV SCALAR
+ B::PV SCALAR
+ B::GV GLOB
+ B::RV REF
+ B::REGEXP REGEXP
+ );
+
+ sub reftype ($) {
+ my $r = shift;
+
+ return undef unless length(ref($r));
+
+ my $t = ref(svref_2object($r));
+
+ return
+ exists $tmap{$t} ? $tmap{$t}
+ : length(ref($$r)) ? 'REF'
+ : 'SCALAR';
+ }
+}
+
+sub tainted {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ no warnings;
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+sub readonly {
+ return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
+
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $tmp = $_[0];
+
+ !eval { $_[0] = $tmp; 1 };
+}
+
+sub looks_like_number {
+ local $_ = shift;
+
+ # checks from perlfaq4
+ return 0 if !defined($_);
+ if (ref($_)) {
+ require overload;
+ return overload::Overloaded($_) ? defined(0 + $_) : 0;
+ }
+ return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
+ return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
+ return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
+
+ 0;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Search/Dict.pm b/Master/tlpkg/tlperl/lib/Search/Dict.pm
new file mode 100644
index 00000000000..5cdd2f42c7a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Search/Dict.pm
@@ -0,0 +1,108 @@
+package Search::Dict;
+require 5.000;
+require Exporter;
+
+use strict;
+
+our $VERSION = '1.02';
+our @ISA = qw(Exporter);
+our @EXPORT = qw(look);
+
+=head1 NAME
+
+Search::Dict, look - search for key in dictionary file
+
+=head1 SYNOPSIS
+
+ use Search::Dict;
+ look *FILEHANDLE, $key, $dict, $fold;
+
+ use Search::Dict;
+ look *FILEHANDLE, $params;
+
+=head1 DESCRIPTION
+
+Sets file position in FILEHANDLE to be first line greater than or equal
+(stringwise) to I<$key>. Returns the new file position, or -1 if an error
+occurs.
+
+The flags specify dictionary order and case folding:
+
+If I<$dict> is true, search by dictionary order (ignore anything but word
+characters and whitespace). The default is honour all characters.
+
+If I<$fold> is true, ignore case. The default is to honour case.
+
+If there are only three arguments and the third argument is a hash
+reference, the keys of that hash can have values C<dict>, C<fold>, and
+C<comp> or C<xfrm> (see below), and their corresponding values will be
+used as the parameters.
+
+If a comparison subroutine (comp) is defined, it must return less than zero,
+zero, or greater than zero, if the first comparand is less than,
+equal, or greater than the second comparand.
+
+If a transformation subroutine (xfrm) is defined, its value is used to
+transform the lines read from the filehandle before their comparison.
+
+=cut
+
+sub look {
+ my($fh,$key,$dict,$fold) = @_;
+ my ($comp, $xfrm);
+ if (@_ == 3 && ref $dict eq 'HASH') {
+ my $params = $dict;
+ $dict = 0;
+ $dict = $params->{dict} if exists $params->{dict};
+ $fold = $params->{fold} if exists $params->{fold};
+ $comp = $params->{comp} if exists $params->{comp};
+ $xfrm = $params->{xfrm} if exists $params->{xfrm};
+ }
+ $comp = sub { $_[0] cmp $_[1] } unless defined $comp;
+ local($_);
+ my(@stat) = stat($fh)
+ or return -1;
+ my($size, $blksize) = @stat[7,11];
+ $blksize ||= 8192;
+ $key =~ s/[^\w\s]//g if $dict;
+ $key = lc $key if $fold;
+ # find the right block
+ my($min, $max) = (0, int($size / $blksize));
+ my $mid;
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek($fh, $mid * $blksize, 0)
+ or return -1;
+ <$fh> if $mid; # probably a partial line
+ $_ = <$fh>;
+ $_ = $xfrm->($_) if defined $xfrm;
+ chomp;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ if (defined($_) && $comp->($_, $key) < 0) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ # find the right line
+ $min *= $blksize;
+ seek($fh,$min,0)
+ or return -1;
+ <$fh> if $min;
+ for (;;) {
+ $min = tell($fh);
+ defined($_ = <$fh>)
+ or last;
+ $_ = $xfrm->($_) if defined $xfrm;
+ chomp;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ last if $comp->($_, $key) >= 0;
+ }
+ seek($fh,$min,0);
+ $min;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Sys/Hostname.pm b/Master/tlpkg/tlperl/lib/Sys/Hostname.pm
new file mode 100644
index 00000000000..415f9517fa4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Sys/Hostname.pm
@@ -0,0 +1,165 @@
+package Sys::Hostname;
+
+use strict;
+
+use Carp;
+
+require Exporter;
+require AutoLoader;
+
+our @ISA = qw/ Exporter AutoLoader /;
+our @EXPORT = qw/ hostname /;
+
+our $VERSION;
+
+our $host;
+
+BEGIN {
+ $VERSION = '1.11';
+ {
+ local $SIG{__DIE__};
+ eval {
+ require XSLoader;
+ XSLoader::load('Sys::Hostname', $VERSION);
+ };
+ warn $@ if $@;
+ }
+}
+
+
+sub hostname {
+
+ # method 1 - we already know it
+ return $host if defined $host;
+
+ # method 1' - try to ask the system
+ $host = ghname() if defined &ghname;
+ return $host if defined $host;
+
+ if ($^O eq 'VMS') {
+
+ # method 2 - no sockets ==> return DECnet node name
+ eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] };
+ if ($@) { return $host = $ENV{'SYS$NODE'}; }
+
+ # method 3 - has someone else done the job already? It's common for the
+ # TCP/IP stack to advertise the hostname via a logical name. (Are
+ # there any other logicals which TCP/IP stacks use for the host name?)
+ $host = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} ||
+ $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} ||
+ $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
+ return $host if $host;
+
+ # method 4 - does hostname happen to work?
+ my($rslt) = `hostname`;
+ if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; }
+ return $host if $host;
+
+ # rats!
+ $host = '';
+ croak "Cannot get host name of local machine";
+
+ }
+ elsif ($^O eq 'MSWin32') {
+ ($host) = gethostbyname('localhost');
+ chomp($host = `hostname 2> NUL`) unless defined $host;
+ return $host;
+ }
+ elsif ($^O eq 'epoc') {
+ $host = 'localhost';
+ return $host;
+ }
+ else { # Unix
+ # is anyone going to make it here?
+
+ local $ENV{PATH} = '/usr/bin:/bin:/usr/sbin:/sbin'; # Paranoia.
+
+ # method 2 - syscall is preferred since it avoids tainting problems
+ # XXX: is it such a good idea to return hostname untainted?
+ eval {
+ local $SIG{__DIE__};
+ require "syscall.ph";
+ $host = "\0" x 65; ## preload scalar
+ syscall(&SYS_gethostname, $host, 65) == 0;
+ }
+
+ # method 2a - syscall using systeminfo instead of gethostname
+ # -- needed on systems like Solaris
+ || eval {
+ local $SIG{__DIE__};
+ require "sys/syscall.ph";
+ require "sys/systeminfo.ph";
+ $host = "\0" x 65; ## preload scalar
+ syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1;
+ }
+
+ # method 3 - trusty old hostname command
+ || eval {
+ local $SIG{__DIE__};
+ local $SIG{CHLD};
+ $host = `(hostname) 2>/dev/null`; # bsdish
+ }
+
+ # method 4 - use POSIX::uname(), which strictly can't be expected to be
+ # correct
+ || eval {
+ local $SIG{__DIE__};
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # method 5 - sysV uname command (may truncate)
+ || eval {
+ local $SIG{__DIE__};
+ $host = `uname -n 2>/dev/null`; ## sysVish
+ }
+
+ # method 6 - Apollo pre-SR10
+ || eval {
+ local $SIG{__DIE__};
+ my($a,$b,$c,$d);
+ ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6);
+ }
+
+ # bummer
+ || croak "Cannot get host name of local machine";
+
+ # remove garbage
+ $host =~ tr/\0\r\n//d;
+ $host;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Sys::Hostname - Try every conceivable way to get hostname
+
+=head1 SYNOPSIS
+
+ use Sys::Hostname;
+ $host = hostname;
+
+=head1 DESCRIPTION
+
+Attempts several methods of getting the system hostname and
+then caches the result. It tries the first available of the C
+library's gethostname(), C<`$Config{aphostname}`>, uname(2),
+C<syscall(SYS_gethostname)>, C<`hostname`>, C<`uname -n`>,
+and the file F</com/host>. If all that fails it C<croak>s.
+
+All NULs, returns, and newlines are removed from the result.
+
+=head1 AUTHOR
+
+David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
+
+Texas Instruments
+
+XS code added by Greg Bacon E<lt>F<gbacon@cs.uah.edu>E<gt>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Base.pm b/Master/tlpkg/tlperl/lib/TAP/Base.pm
new file mode 100644
index 00000000000..f88ad11134c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Base.pm
@@ -0,0 +1,129 @@
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+use constant GOT_TIME_HIRES => do {
+ eval 'use Time::HiRes qw(time);';
+ $@ ? 0 : 1;
+};
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
+
+ # ... later ...
+
+ my $thing = TAP::Whatever->new();
+
+ $thing->callback( event => sub {
+ # do something interesting
+ } );
+
+=head1 DESCRIPTION
+
+C<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for, $ok_callback ) = @_;
+
+ my %ok_map = map { $_ => 1 } @$ok_callback;
+
+ $self->{ok_callbacks} = \%ok_map;
+
+ if ( my $cb = delete $arg_for->{callbacks} ) {
+ while ( my ( $event, $callback ) = each %$cb ) {
+ $self->callback( $event, $callback );
+ }
+ }
+
+ return $self;
+}
+
+=head3 C<callback>
+
+Install a callback for a named event.
+
+=cut
+
+sub callback {
+ my ( $self, $event, $callback ) = @_;
+
+ my %ok_map = %{ $self->{ok_callbacks} };
+
+ $self->_croak('No callbacks may be installed')
+ unless %ok_map;
+
+ $self->_croak( "Callback $event is not supported. Valid callbacks are "
+ . join( ', ', sort keys %ok_map ) )
+ unless exists $ok_map{$event};
+
+ push @{ $self->{code_for}{$event} }, $callback;
+
+ return;
+}
+
+sub _has_callbacks {
+ my $self = shift;
+ return keys %{ $self->{code_for} } != 0;
+}
+
+sub _callback_for {
+ my ( $self, $event ) = @_;
+ return $self->{code_for}{$event};
+}
+
+sub _make_callback {
+ my $self = shift;
+ my $event = shift;
+
+ my $cb = $self->_callback_for($event);
+ return unless defined $cb;
+ return map { $_->(@_) } @$cb;
+}
+
+=head3 C<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
+
+=cut
+
+sub time_is_hires { return GOT_TIME_HIRES }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm
new file mode 100644
index 00000000000..f2b54a9ba3e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm
@@ -0,0 +1,449 @@
+package TAP::Formatter::Base;
+
+use strict;
+use TAP::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+my $MAX_ERRORS = 5;
+my %VALIDATION_FOR;
+
+BEGIN {
+ @ISA = qw(TAP::Base);
+
+ %VALIDATION_FOR = (
+ directives => sub { shift; shift },
+ verbosity => sub { shift; shift },
+ normalize => sub { shift; shift },
+ timer => sub { shift; shift },
+ failures => sub { shift; shift },
+ comments => sub { shift; shift },
+ errors => sub { shift; shift },
+ color => sub { shift; shift },
+ jobs => sub { shift; shift },
+ show_count => sub { shift; shift },
+ stdout => sub {
+ my ( $self, $ref ) = @_;
+ $self->_croak("option 'stdout' needs a filehandle")
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
+ return $ref;
+ },
+ );
+
+ my @getter_setters = qw(
+ _longest
+ _printed_summary_header
+ _colorizer
+ );
+
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ $self->verbosity(0);
+
+ for my $name ( keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+ $self->$name( $self->$validate($property) );
+ }
+ }
+
+ if ( my @props = keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ $self->stdout( \*STDOUT ) unless $self->stdout;
+
+ if ( $self->color ) {
+ require TAP::Formatter::Color;
+ $self->_colorizer( TAP::Formatter::Color->new );
+ }
+
+ return $self;
+}
+
+sub verbose { shift->verbosity >= 1 }
+sub quiet { shift->verbosity <= -1 }
+sub really_quiet { shift->verbosity <= -2 }
+sub silent { shift->verbosity <= -3 }
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> is automatically created. If any of the
+following options were given to TAP::Harness->new they well be passed to
+this constructor which accepts an optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose>, C<failures>, or C<comments>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_output($msg);
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+
+ return if $self->silent;
+
+ my @t = $aggregate->descriptions;
+ my $tests = \@t;
+
+ my $runtime = $aggregate->elapsed_timestr;
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ if ( $self->timer ) {
+ $self->_output( $self->_format_now(), "\n" );
+ }
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $aggregate->all_passed ) {
+ $self->_output_success("All tests successful.\n");
+ }
+
+ # ~TODO option where $aggregate->skipped generates reports
+ if ( $total != $passed or $aggregate->has_problems ) {
+ $self->_output("\nTest Summary Report");
+ $self->_output("\n-------------------\n");
+ foreach my $test (@$tests) {
+ $self->_printed_summary_header(0);
+ my ($parser) = $aggregate->parsers($test);
+ $self->_output_summary_failure(
+ 'failed',
+ [ ' Failed test: ', ' Failed tests: ' ],
+ $test, $parser
+ );
+ $self->_output_summary_failure(
+ 'todo_passed',
+ " TODO passed: ", $test, $parser
+ );
+
+ # ~TODO this cannot be the default
+ #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
+
+ if ( my $exit = $parser->exit ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero exit status: $exit\n");
+ }
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }
+
+ if ( my @errors = $parser->parse_errors ) {
+ my $explain;
+ if ( @errors > $MAX_ERRORS && !$self->errors ) {
+ $explain
+ = "Displayed the first $MAX_ERRORS of "
+ . scalar(@errors)
+ . " TAP syntax errors.\n"
+ . "Re-run prove with the -p option to see them all.\n";
+ splice @errors, $MAX_ERRORS;
+ }
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(
+ sprintf " Parse errors: %s\n",
+ shift @errors
+ );
+ foreach my $error (@errors) {
+ my $spaces = ' ' x 16;
+ $self->_failure_output("$spaces$error\n");
+ }
+ $self->_failure_output($explain) if $explain;
+ }
+ }
+ }
+ my $files = @$tests;
+ $self->_output("Files=$files, Tests=$total, $runtime\n");
+ my $status = $aggregate->get_status;
+ $self->_output("Result: $status\n");
+}
+
+sub _output_summary_failure {
+ my ( $self, $method, $name, $test, $parser ) = @_;
+
+ # ugly hack. Must rethink this :(
+ my $output = $method eq 'failed' ? '_failure_output' : '_output';
+
+ if ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $self->$output( sprintf "%s\n" => shift @results );
+ my $spaces = ' ' x 16;
+ while (@results) {
+ $self->$output( sprintf "$spaces%s\n" => shift @results );
+ }
+ }
+}
+
+sub _summary_test_header {
+ my ( $self, $test, $parser ) = @_;
+ return if $self->_printed_summary_header;
+ my $spaces = ' ' x ( $self->_longest - length $test );
+ $spaces = ' ' unless $spaces;
+ my $output = $self->_get_output_method($parser);
+ $self->$output(
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
+ );
+ $self->_printed_summary_header(1);
+}
+
+sub _output {
+ my $self = shift;
+
+ print { $self->stdout } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+sub _balanced_range {
+ my ( $self, $limit, @range ) = @_;
+ @range = $self->_range(@range);
+ my $line = "";
+ my @lines;
+ my $curr = 0;
+ while (@range) {
+ if ( $curr < $limit ) {
+ my $range = ( shift @range ) . ", ";
+ $line .= $range;
+ $curr += length $range;
+ }
+ elsif (@range) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ $line = '';
+ $curr = 0;
+ }
+ }
+ if ($line) {
+ $line =~ s/, $//;
+ push @lines => $line;
+ }
+ return @lines;
+}
+
+sub _range {
+ my ( $self, @numbers ) = @_;
+
+ # shouldn't be needed, but subclasses might call this
+ @numbers = sort { $a <=> $b } @numbers;
+ my ( $min, @range );
+
+ foreach my $i ( 0 .. $#numbers ) {
+ my $num = $numbers[$i];
+ my $next = $numbers[ $i + 1 ];
+ if ( defined $next && $next == $num + 1 ) {
+ if ( !defined $min ) {
+ $min = $num;
+ }
+ }
+ elsif ( defined $min ) {
+ push @range => "$min-$num";
+ undef $min;
+ }
+ else {
+ push @range => $num;
+ }
+ }
+ return @range;
+}
+
+sub _get_output_method {
+ my ( $self, $parser ) = @_;
+ return $parser->has_problems ? '_failure_output' : '_output';
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm
new file mode 100644
index 00000000000..349d3b84bf4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm
@@ -0,0 +1,148 @@
+package TAP::Formatter::Color;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+
+@ISA = qw(TAP::Object);
+
+my $NO_COLOR;
+
+BEGIN {
+ $NO_COLOR = 0;
+
+ if (IS_WIN32) {
+ eval 'use Win32::Console';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
+
+ # eval here because we might not know about these variables
+ my $fg = eval '$FG_LIGHTGRAY';
+ my $bg = eval '$BG_BLACK';
+
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+
+ my $var;
+ if ( $color eq 'reset' ) {
+ $fg = eval '$FG_LIGHTGRAY';
+ $bg = eval '$BG_BLACK';
+ }
+ elsif ( $color =~ /^on_(.+)$/ ) {
+ $bg = eval '$BG_' . uc($1);
+ }
+ else {
+ $fg = eval '$FG_' . uc($color);
+ }
+
+ # In case of colors that aren't defined
+ $self->set_color('reset')
+ unless defined $bg && defined $fg;
+
+ $console->Attr( $bg | $fg );
+ };
+ }
+ }
+ else {
+ eval 'use Term::ANSIColor';
+ if ($@) {
+ $NO_COLOR = $@;
+ }
+ else {
+ *set_color = sub {
+ my ( $self, $output, $color ) = @_;
+ $output->( color($color) );
+ };
+ }
+ }
+
+ if ($NO_COLOR) {
+ *set_color = sub { };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Color - Run Perl test scripts with color
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+Note that this harness is I<experimental>. You may not like the colors I've
+chosen and I haven't yet provided an easy way to override them.
+
+This test harness is the same as L<TAP::Harness>, but test results are output
+in color. Passing tests are printed in green. Failing tests are in red.
+Skipped tests are blue on a white background and TODO tests are printed in
+white.
+
+If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
+under Windows) tests will be run without color.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Color;
+ my $harness = TAP::Formatter::Color->new( \%args );
+ $harness->runtests(@tests);
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> is not installed, returns undef.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+
+ if ($NO_COLOR) {
+
+ # shorten that message a bit
+ ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
+ warn "Note: Cannot run tests in color: $error\n";
+ return; # abort object construction
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<can_color>
+
+ Test::Formatter::Color->can_color()
+
+Returns a boolean indicating whether or not this module can actually
+generate colored output. This will be false if it could not load the
+modules needed for the current platform.
+
+=cut
+
+sub can_color {
+ return !$NO_COLOR;
+}
+
+=head3 C<set_color>
+
+Set the output color.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm
new file mode 100644
index 00000000000..aeca2f2b0d5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm
@@ -0,0 +1,91 @@
+package TAP::Formatter::Console;
+
+use strict;
+use TAP::Formatter::Base ();
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::Console;
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $class
+ = $self->jobs > 1
+ ? 'TAP::Formatter::Console::ParallelSession'
+ : 'TAP::Formatter::Console::Session';
+
+ eval "require $class";
+ $self->_croak($@) if $@;
+
+ my $session = $class->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+# Use _colorizer delegate to set output color. NOP if we have no delegate
+sub _set_colors {
+ my ( $self, @colors ) = @_;
+ if ( my $colorizer = $self->_colorizer ) {
+ my $output_func = $self->{_output_func} ||= sub {
+ $self->_output(@_);
+ };
+ $colorizer->set_color( $output_func, $_ ) for @colors;
+ }
+}
+
+sub _output_success {
+ my ( $self, $msg ) = @_;
+ $self->_set_colors('green');
+ $self->_output($msg);
+ $self->_set_colors('reset');
+}
+
+sub _failure_output {
+ my $self = shift;
+ $self->_set_colors('red');
+ my $out = join '', @_;
+ my $has_newline = chomp $out;
+ $self->_output($out);
+ $self->_set_colors('reset');
+ $self->_output($/)
+ if $has_newline;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm
new file mode 100644
index 00000000000..b6b5134cda1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm
@@ -0,0 +1,202 @@
+package TAP::Formatter::Console::ParallelSession;
+
+use strict;
+use File::Spec;
+use File::Path;
+use TAP::Formatter::Console::Session;
+use Carp;
+
+use constant WIDTH => 72; # Because Eric says
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Console::Session);
+
+my %shared;
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ $self->SUPER::_initialize($arg_for);
+ my $formatter = $self->formatter;
+
+ # Horrid bodge. This creates our shared context per harness. Maybe
+ # TAP::Harness should give us this?
+ my $context = $shared{$formatter} ||= $self->_create_shared_context;
+ push @{ $context->{active} }, $self;
+
+ return $self;
+}
+
+sub _create_shared_context {
+ my $self = shift;
+ return {
+ active => [],
+ tests => 0,
+ fails => 0,
+ };
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+Output test preamble
+
+=cut
+
+sub header {
+}
+
+sub _clear_ruler {
+ my $self = shift;
+ $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
+}
+
+my $now = 0;
+my $start;
+
+my $trailer = '... )===';
+my $chop_length = WIDTH - length $trailer;
+
+sub _output_ruler {
+ my ( $self, $refresh ) = @_;
+ my $new_now = time;
+ return if $new_now == $now and !$refresh;
+ $now = $new_now;
+ $start ||= $now;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $context = $shared{$formatter};
+
+ my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
+
+ foreach my $active ( @{ $context->{active} } ) {
+ my $parser = $active->parser;
+ my $tests = $parser->tests_run;
+ my $planned = $parser->tests_planned || '?';
+
+ $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
+ }
+ chop $ruler; # Remove a trailing space
+ $ruler .= ')===';
+
+ if ( length $ruler > WIDTH ) {
+ $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
+ }
+ else {
+ $ruler .= '=' x ( WIDTH - length($ruler) );
+ }
+ $formatter->_output("\r$ruler");
+}
+
+=head3 C<result>
+
+ Called by the harness for each line of TAP it receives .
+
+=cut
+
+sub result {
+ my ( $self, $result ) = @_;
+ my $formatter = $self->formatter;
+
+ # my $really_quiet = $formatter->really_quiet;
+ # my $show_count = $self->_should_show_count;
+
+ if ( $result->is_test ) {
+ my $context = $shared{$formatter};
+ $context->{tests}++;
+
+ my $active = $context->{active};
+ if ( @$active == 1 ) {
+
+ # There is only one test, so use the serial output format.
+ return $self->SUPER::result($result);
+ }
+
+ $self->_output_ruler( $self->parser->tests_run == 1 );
+ }
+ elsif ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+}
+
+=head3 C<clear_for_close>
+
+=cut
+
+sub clear_for_close {
+ my $self = shift;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+ my $context = $shared{$formatter};
+ if ( @{ $context->{active} } == 1 ) {
+ $self->SUPER::clear_for_close;
+ }
+ else {
+ $self->_clear_ruler;
+ }
+}
+
+=head3 C<close_test>
+
+=cut
+
+sub close_test {
+ my $self = shift;
+ my $name = $self->name;
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $context = $shared{$formatter};
+
+ $self->SUPER::close_test;
+
+ my $active = $context->{active};
+
+ my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
+
+ die "Can't find myself" unless @pos;
+ splice @$active, $pos[0], 1;
+
+ if ( @$active > 1 ) {
+ $self->_output_ruler(1);
+ }
+ elsif ( @$active == 1 ) {
+
+ # Print out "test/name.t ...."
+ $active->[0]->SUPER::header;
+ }
+ else {
+
+ # $self->formatter->_output("\n");
+ delete $shared{$formatter};
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm
new file mode 100644
index 00000000000..675512c71d0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm
@@ -0,0 +1,219 @@
+package TAP::Formatter::Console::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+my @ACCESSOR;
+
+BEGIN {
+ my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
+
+ for my $method (@CLOSURE_BINDING) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return ( $self->{_closures} ||= $self->_closures )->{$method}
+ ->(@_);
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console::Session - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides console orientated output formatting for TAP::Harness.
+
+=cut
+
+sub _get_output_result {
+ my $self = shift;
+
+ my @color_map = (
+ { test => sub { $_->is_test && !$_->is_ok },
+ colors => ['red'],
+ },
+ { test => sub { $_->is_test && $_->has_skip },
+ colors => [
+ 'white',
+ 'on_blue'
+ ],
+ },
+ { test => sub { $_->is_test && $_->has_todo },
+ colors => ['yellow'],
+ },
+ );
+
+ my $formatter = $self->formatter;
+ my $parser = $self->parser;
+
+ return $formatter->_colorizer
+ ? sub {
+ my $result = shift;
+ for my $col (@color_map) {
+ local $_ = $result;
+ if ( $col->{test}->() ) {
+ $formatter->_set_colors( @{ $col->{colors} } );
+ last;
+ }
+ }
+ $formatter->_output( $self->_format_for_output($result) );
+ $formatter->_set_colors('reset');
+ }
+ : sub {
+ $formatter->_output( $self->_format_for_output(shift) );
+ };
+}
+
+sub _closures {
+ my $self = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+ my $show_count = $self->show_count;
+
+ my $really_quiet = $formatter->really_quiet;
+ my $quiet = $formatter->quiet;
+ my $verbose = $formatter->verbose;
+ my $directives = $formatter->directives;
+ my $failures = $formatter->failures;
+ my $comments = $formatter->comments;
+
+ my $output_result = $self->_get_output_result;
+
+ my $output = '_output';
+ my $plan = '';
+ my $newline_printed = 0;
+
+ my $last_status_printed = 0;
+
+ return {
+ header => sub {
+ $formatter->_output($pretty)
+ unless $really_quiet;
+ },
+
+ result => sub {
+ my $result = shift;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ }
+
+ return if $really_quiet;
+
+ my $is_test = $result->is_test;
+
+ # These are used in close_test - but only if $really_quiet
+ # is false - so it's safe to only set them here unless that
+ # relationship changes.
+
+ if ( !$plan ) {
+ my $planned = $parser->tests_planned || '?';
+ $plan = "/$planned ";
+ }
+ $output = $formatter->_get_output_method($parser);
+
+ if ( $show_count and $is_test ) {
+ my $number = $result->number;
+ my $now = CORE::time;
+
+ # Print status roughly once per second.
+ # We will always get the first number as a side effect of
+ # $last_status_printed starting with the value 0, which $now
+ # will never be. (Unless someone sets their clock to 1970)
+ if ( $last_status_printed != $now ) {
+ $formatter->$output("\r$pretty$number$plan");
+ $last_status_printed = $now;
+ }
+ }
+
+ if (!$quiet
+ && ( $verbose
+ || ( $is_test && $failures && !$result->is_ok )
+ || ( $comments && $result->is_comment )
+ || ( $directives && $result->has_directive ) )
+ )
+ {
+ unless ($newline_printed) {
+ $formatter->_output("\n");
+ $newline_printed = 1;
+ }
+ $output_result->($result);
+ $formatter->_output("\n");
+ }
+ },
+
+ clear_for_close => sub {
+ my $spaces
+ = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
+ $formatter->$output("\r$spaces");
+ },
+
+ close_test => sub {
+ if ( $show_count && !$really_quiet ) {
+ $self->clear_for_close;
+ $formatter->$output("\r$pretty");
+ }
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
+ return if $really_quiet;
+
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output("skipped: $skip_all\n");
+ }
+ elsif ( $parser->has_problems ) {
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output("ok$time_report\n");
+ }
+ },
+ };
+}
+
+=head2 C<< clear_for_close >>
+
+=head2 C<< close_test >>
+
+=head2 C<< header >>
+
+=head2 C<< result >>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm
new file mode 100644
index 00000000000..8514bc068bb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm
@@ -0,0 +1,58 @@
+package TAP::Formatter::File;
+
+use strict;
+use TAP::Formatter::Base ();
+use TAP::Formatter::File::Session;
+use POSIX qw(strftime);
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
+=head1 NAME
+
+TAP::Formatter::File - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for TAP::Harness.
+
+=head1 SYNOPSIS
+
+ use TAP::Formatter::File;
+ my $harness = TAP::Formatter::File->new( \%args );
+
+=head2 C<< open_test >>
+
+See L<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm
new file mode 100644
index 00000000000..c6abfd63bcc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm
@@ -0,0 +1,110 @@
+package TAP::Formatter::File::Session;
+
+use strict;
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
+
+=head1 NAME
+
+TAP::Formatter::File::Session - Harness output delegate for file output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This provides file orientated output formatting for L<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( $formatter->verbose
+ || ( $result->is_test && $formatter->failures && !$result->is_ok )
+ || ( $formatter->comments && $result->is_comment )
+ || ( $result->has_directive && $formatter->directives ) )
+ )
+ {
+ $self->{results} .= $self->_format_for_output($result) . "\n";
+ }
+}
+
+=head2 close_test
+
+When the test file finishes, outputs the summary, together.
+
+=cut
+
+sub close_test {
+ my $self = shift;
+
+ # Avoid circular references
+ $self->parser(undef);
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+ my $pretty = $formatter->_format_name( $self->name );
+
+ return if $formatter->really_quiet;
+ if ( my $skip_all = $parser->skip_all ) {
+ $formatter->_output( $pretty . "skipped: $skip_all\n" );
+ }
+ elsif ( $parser->has_problems ) {
+ $formatter->_output(
+ $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) );
+ $self->_output_test_failure($parser);
+ }
+ else {
+ my $time_report = '';
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ $time_report
+ = $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ }
+
+ $formatter->_output( $pretty
+ . ( $self->{results} ? "\n" . $self->{results} : "" )
+ . "ok$time_report\n" );
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm
new file mode 100644
index 00000000000..21767e5eba7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm
@@ -0,0 +1,183 @@
+package TAP::Formatter::Session;
+
+use strict;
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+my @ACCESSOR;
+
+BEGIN {
+
+ @ACCESSOR = qw( name formatter parser show_count );
+
+ for my $method (@ACCESSOR) {
+ no strict 'refs';
+ *$method = sub { shift->{$method} };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Session - Abstract base class for harness output delegate
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=cut
+
+sub header { }
+
+sub result { }
+
+sub close_test { }
+
+sub clear_for_close { }
+
+sub _should_show_count {
+ my $self = shift;
+ return
+ !$self->formatter->verbose
+ && -t $self->formatter->stdout
+ && !$ENV{HARNESS_NOTTY};
+}
+
+sub _format_for_output {
+ my ( $self, $result ) = @_;
+ return $self->formatter->normalize ? $result->as_string : $result->raw;
+}
+
+sub _output_test_failure {
+ my ( $self, $parser ) = @_;
+ my $formatter = $self->formatter;
+ return if $formatter->really_quiet;
+
+ my $tests_run = $parser->tests_run;
+ my $tests_planned = $parser->tests_planned;
+
+ my $total
+ = defined $tests_planned
+ ? $tests_planned
+ : $tests_run;
+
+ my $passed = $parser->passed;
+
+ # The total number of fails includes any tests that were planned but
+ # didn't run
+ my $failed = $parser->failed + $total - $tests_run;
+ my $exit = $parser->exit;
+
+ if ( my $exit = $parser->exit ) {
+ my $wstat = $parser->wait;
+ my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
+ $formatter->_failure_output("Dubious, test returned $status\n");
+ }
+
+ if ( $failed == 0 ) {
+ $formatter->_failure_output(
+ $total
+ ? "All $total subtests passed "
+ : 'No subtests run '
+ );
+ }
+ else {
+ $formatter->_failure_output("Failed $failed/$total subtests ");
+ if ( !$total ) {
+ $formatter->_failure_output("\nNo tests run!");
+ }
+ }
+
+ if ( my $skipped = $parser->skipped ) {
+ $passed -= $skipped;
+ my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
+ $formatter->_output(
+ "\n\t(less $skipped skipped $test: $passed okay)");
+ }
+
+ if ( my $failed = $parser->todo_passed ) {
+ my $test = $failed > 1 ? 'tests' : 'test';
+ $formatter->_output(
+ "\n\t($failed TODO $test unexpectedly succeeded)");
+ }
+
+ $formatter->_output("\n");
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Harness.pm b/Master/tlpkg/tlperl/lib/TAP/Harness.pm
new file mode 100644
index 00000000000..749e7af4166
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Harness.pm
@@ -0,0 +1,830 @@
+package TAP::Harness;
+
+use strict;
+use Carp;
+
+use File::Spec;
+use File::Path;
+use IO::Handle;
+
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
+
+=head1 NAME
+
+TAP::Harness - Run test scripts with statistics
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+=head1 DESCRIPTION
+
+This is a simple test harness which allows tests to be run and results
+automatically aggregated and output to STDOUT.
+
+=head1 SYNOPSIS
+
+ use TAP::Harness;
+ my $harness = TAP::Harness->new( \%args );
+ $harness->runtests(@tests);
+
+=cut
+
+my %VALIDATION_FOR;
+my @FORMATTER_ARGS;
+
+sub _error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+}
+
+BEGIN {
+
+ @FORMATTER_ARGS = qw(
+ directives verbosity timer failures comments errors stdout color
+ show_count normalize
+ );
+
+ %VALIDATION_FOR = (
+ lib => sub {
+ my ( $self, $libs ) = @_;
+ $libs = [$libs] unless 'ARRAY' eq ref $libs;
+
+ return [ map {"-I$_"} @$libs ];
+ },
+ switches => sub { shift; shift },
+ exec => sub { shift; shift },
+ merge => sub { shift; shift },
+ aggregator_class => sub { shift; shift },
+ formatter_class => sub { shift; shift },
+ multiplexer_class => sub { shift; shift },
+ parser_class => sub { shift; shift },
+ scheduler_class => sub { shift; shift },
+ formatter => sub { shift; shift },
+ jobs => sub { shift; shift },
+ test_args => sub { shift; shift },
+ ignore_exit => sub { shift; shift },
+ rules => sub { shift; shift },
+ );
+
+ for my $method ( sort keys %VALIDATION_FOR ) {
+ no strict 'refs';
+ if ( $method eq 'lib' || $method eq 'switches' ) {
+ *{$method} = sub {
+ my $self = shift;
+ unless (@_) {
+ $self->{$method} ||= [];
+ return wantarray
+ ? @{ $self->{$method} }
+ : $self->{$method};
+ }
+ $self->_croak("Too many arguments to method '$method'")
+ if @_ > 1;
+ my $args = shift;
+ $args = [$args] unless ref $args;
+ $self->{$method} = $args;
+ return $self;
+ };
+ }
+ else {
+ *{$method} = sub {
+ my $self = shift;
+ return $self->{$method} unless @_;
+ $self->{$method} = shift;
+ };
+ }
+ }
+
+ for my $method (@FORMATTER_ARGS) {
+ no strict 'refs';
+ *{$method} = sub {
+ my $self = shift;
+ return $self->formatter->$method(@_);
+ };
+ }
+}
+
+##############################################################################
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib', 'blib/arch' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level:
+
+ 1 verbose Print individual test results to STDOUT.
+ 0 normal
+ -1 quiet Suppress some test output (mostly failures
+ while tests are running).
+ -2 really quiet Suppress everything but the tests summary.
+ -3 silent Suppress everything.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
+
+=item * C<failures>
+
+Show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<comments>
+
+Show test comments (this is a no-op if C<verbose> is selected).
+
+=item * C<show_count>
+
+Update the running test count during testing.
+
+=item * C<normalize>
+
+Set to a true value to normalize the TAP that is emitted in verbose modes.
+
+=item * C<lib>
+
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
+
+=item * C<switches>
+
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
+
+=item * C<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+Typically, Perl tests are run through this. However, anything which
+spits out TAP is fine. You can use this argument to specify the name of
+the program (and optional switches) to run your tests with:
+
+ exec => ['/usr/bin/ruby', '-w']
+
+You can also pass a subroutine reference in order to determine and
+return the proper program to run based on a given test script. The
+subroutine reference should expect the TAP::Harness object itself as the
+first argument, and the file name as the second argument. It should
+return an array reference containing the command to be run and including
+the test file name. It can also simply return C<undef>, in which case
+TAP::Harness will fall back on executing the test script in Perl:
+
+ exec => sub {
+ my ( $harness, $test_file ) = @_;
+
+ # Let Perl tests run.
+ return undef if $test_file =~ /[.]t$/;
+ return [ qw( /usr/bin/ruby -w ), $test_file ]
+ if $test_file =~ /[.]rb$/;
+ }
+
+If the subroutine returns a scalar with a newline or a filehandle, it
+will be interpreted as raw TAP or as a TAP stream, respectively.
+
+=item * C<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
+
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
+
+=item * C<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+{
+ my @legal_callback = qw(
+ parser_args
+ made_parser
+ before_runtests
+ after_runtests
+ after_test
+ );
+
+ my %default_class = (
+ aggregator_class => 'TAP::Parser::Aggregator',
+ formatter_class => 'TAP::Formatter::Console',
+ multiplexer_class => 'TAP::Parser::Multiplexer',
+ parser_class => 'TAP::Parser',
+ scheduler_class => 'TAP::Parser::Scheduler',
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize( $arg_for, \@legal_callback );
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name ( sort keys %VALIDATION_FOR ) {
+ my $property = delete $arg_for{$name};
+ if ( defined $property ) {
+ my $validate = $VALIDATION_FOR{$name};
+
+ my $value = $self->$validate($property);
+ if ( $self->_error ) {
+ $self->_croak;
+ }
+ $self->$name($value);
+ }
+ }
+
+ $self->jobs(1) unless defined $self->jobs;
+
+ local $default_class{formatter_class} = 'TAP::Formatter::File'
+ unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
+
+ while ( my ( $attr, $class ) = each %default_class ) {
+ $self->$attr( $self->$attr() || $class );
+ }
+
+ unless ( $self->formatter ) {
+
+ # This is a little bodge to preserve legacy behaviour. It's
+ # pretty horrible that we know which args are destined for
+ # the formatter.
+ my %formatter_args = ( jobs => $self->jobs );
+ for my $name (@FORMATTER_ARGS) {
+ if ( defined( my $property = delete $arg_for{$name} ) ) {
+ $formatter_args{$name} = $property;
+ }
+ }
+
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
+ }
+
+ return $self;
+ }
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<runtests>
+
+ $harness->runtests(@tests);
+
+Accepts and array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
+
+It is possible to provide aliases that will be displayed in place of the
+test name by supplying the test as a reference to an array containing
+C<< [ $test, $alias ] >>:
+
+ $harness->runtests( [ 't/foo.t', 'Foo Once' ],
+ [ 't/foo.t', 'Foo Twice' ] );
+
+Normally it is an error to attempt to run the same test twice. Aliases
+allow you to overcome this limitation by giving each run of the test a
+unique name.
+
+Tests will be run in the order found.
+
+If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
+should name a directory into which a copy of the raw TAP for each test
+will be written. TAP is written to files named for each test.
+Subdirectories will be created as needed.
+
+Returns a L<TAP::Parser::Aggregator> containing the test results.
+
+=cut
+
+sub runtests {
+ my ( $self, @tests ) = @_;
+
+ my $aggregate = $self->_construct( $self->aggregator_class );
+
+ $self->_make_callback( 'before_runtests', $aggregate );
+ $aggregate->start;
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
+
+ return $aggregate;
+}
+
+=head3 C<summary>
+
+Output the summary for a TAP::Parser::Aggregator.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
+}
+
+sub _after_test {
+ my ( $self, $aggregate, $job, $parser ) = @_;
+
+ $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+ $aggregate->add( $job->description, $parser );
+}
+
+sub _bailout {
+ my ( $self, $result ) = @_;
+ my $explanation = $result->explanation;
+ die "FAILED--Further testing stopped"
+ . ( $explanation ? ": $explanation\n" : ".\n" );
+}
+
+sub _aggregate_parallel {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ my $jobs = $self->jobs;
+ my $mux = $self->_construct( $self->multiplexer_class );
+
+ RESULT: {
+
+ # Keep multiplexer topped up
+ FILL:
+ while ( $mux->parsers < $jobs ) {
+ my $job = $scheduler->get_job;
+
+ # If we hit a spinner stop filling and start running.
+ last FILL if !defined $job || $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+ $mux->add( $parser, [ $session, $job ] );
+ }
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ my ( $session, $job ) = @$stash;
+ if ( defined $result ) {
+ $session->result($result);
+ $self->_bailout($result) if $result->is_bailout;
+ }
+ else {
+
+ # End of parser. Automatically removed from the mux.
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+ redo RESULT;
+ }
+ }
+
+ return;
+}
+
+sub _aggregate_single {
+ my ( $self, $aggregate, $scheduler ) = @_;
+
+ JOB:
+ while ( my $job = $scheduler->get_job ) {
+ next JOB if $job->is_spinner;
+
+ my ( $parser, $session ) = $self->make_parser($job);
+
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ if ( $result->is_bailout ) {
+
+ # Keep reading until input is exhausted in the hope
+ # of allowing any pending diagnostics to show up.
+ 1 while $parser->next;
+ $self->_bailout($result);
+ }
+ }
+
+ $self->finish_parser( $parser, $session );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
+ }
+
+ return;
+}
+
+=head3 C<aggregate_tests>
+
+ $harness->aggregate_tests( $aggregate, @tests );
+
+Run the named tests and display a summary of result. Tests will be run
+in the order found.
+
+Test results will be added to the supplied L<TAP::Parser::Aggregator>.
+C<aggregate_tests> may be called multiple times to run several sets of
+tests. Multiple C<Test::Harness> instances may be used to pass results
+to a single aggregator so that different parts of a complex test suite
+may be run using different C<TAP::Harness> settings. This is useful, for
+example, in the case where some tests should run in parallel but others
+are unsuitable for parallel execution.
+
+ my $formatter = TAP::Formatter::Console->new;
+ my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
+ my $par_harness = TAP::Harness->new(
+ { formatter => $formatter,
+ jobs => 9
+ }
+ );
+ my $aggregator = TAP::Parser::Aggregator->new;
+
+ $aggregator->start();
+ $ser_harness->aggregate_tests( $aggregator, @ser_tests );
+ $par_harness->aggregate_tests( $aggregator, @par_tests );
+ $aggregator->stop();
+ $formatter->summary($aggregator);
+
+Note that for simpler testing requirements it will often be possible to
+replace the above code with a single call to C<runtests>.
+
+Each elements of the @tests array is either
+
+=over
+
+=item * the file name of a test script to run
+
+=item * a reference to a [ file name, display name ] array
+
+=back
+
+When you supply a separate display name it becomes possible to run a
+test more than once; the display name is effectively the alias by which
+the test is known inside the harness. The harness doesn't care if it
+runs the same script more than once when each invocation uses a
+different name.
+
+=cut
+
+sub aggregate_tests {
+ my ( $self, $aggregate, @tests ) = @_;
+
+ my $jobs = $self->jobs;
+ my $scheduler = $self->make_scheduler(@tests);
+
+ # #12458
+ local $ENV{HARNESS_IS_VERBOSE} = 1
+ if $self->formatter->verbosity > 0;
+
+ # Formatter gets only names.
+ $self->formatter->prepare( map { $_->description } $scheduler->get_all );
+
+ if ( $self->jobs > 1 ) {
+ $self->_aggregate_parallel( $aggregate, $scheduler );
+ }
+ else {
+ $self->_aggregate_single( $aggregate, $scheduler );
+ }
+
+ return;
+}
+
+sub _add_descriptions {
+ my $self = shift;
+
+ # Turn unwrapped scalars into anonymous arrays and copy the name as
+ # the description for tests that have only a name.
+ return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
+ map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+ my ( $self, @tests ) = @_;
+ return $self->_construct(
+ $self->scheduler_class,
+ tests => [ $self->_add_descriptions(@tests) ],
+ rules => $self->rules
+ );
+}
+
+=head3 C<jobs>
+
+Gets or sets the number of concurrent test runs the harness is
+handling. By default, this value is 1 -- for parallel testing, this
+should be set higher.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests
+started. You can print a useful summary time, if desired, with:
+
+ $self->output(
+ timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
+sub _get_parser_args {
+ my ( $self, $job ) = @_;
+ my $test_prog = $job->filename;
+ my %args = ();
+ my @switches;
+ @switches = $self->lib if $self->lib;
+ push @switches => $self->switches if $self->switches;
+ $args{switches} = \@switches;
+ $args{spool} = $self->_open_spool($test_prog);
+ $args{merge} = $self->merge;
+ $args{ignore_exit} = $self->ignore_exit;
+
+ if ( my $exec = $self->exec ) {
+ $args{exec}
+ = ref $exec eq 'CODE'
+ ? $exec->( $self, $test_prog )
+ : [ @$exec, $test_prog ];
+ if ( not defined $args{exec} ) {
+ $args{source} = $test_prog;
+ }
+ elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
+ $args{source} = delete $args{exec};
+ }
+ }
+ else {
+ $args{source} = $test_prog;
+ }
+
+ if ( defined( my $test_args = $self->test_args ) ) {
+ $args{test_args} = $test_args;
+ }
+
+ return \%args;
+}
+
+=head3 C<make_parser>
+
+Make a new parser and display formatter session. Typically used and/or
+overridden in subclasses.
+
+ my ( $parser, $session ) = $harness->make_parser;
+
+=cut
+
+sub make_parser {
+ my ( $self, $job ) = @_;
+
+ my $args = $self->_get_parser_args($job);
+ $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
+ my $parser = $self->_construct( $self->parser_class, $args );
+
+ $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+ my $session = $self->formatter->open_test( $job->description, $parser );
+
+ return ( $parser, $session );
+}
+
+=head3 C<finish_parser>
+
+Terminate use of a parser. Typically used and/or overridden in
+subclasses. The parser isn't destroyed as a result of this.
+
+=cut
+
+sub finish_parser {
+ my ( $self, $parser, $session ) = @_;
+
+ $session->close_test;
+ $self->_close_spool($parser);
+
+ return $parser;
+}
+
+sub _open_spool {
+ my $self = shift;
+ my $test = shift;
+
+ if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
+
+ my $spool = File::Spec->catfile( $spool_dir, $test );
+
+ # Make the directory
+ my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
+ my $path = File::Spec->catpath( $vol, $dir, '' );
+ eval { mkpath($path) };
+ $self->_croak($@) if $@;
+
+ my $spool_handle = IO::Handle->new;
+ open( $spool_handle, ">$spool" )
+ or $self->_croak(" Can't write $spool ( $! ) ");
+
+ return $spool_handle;
+ }
+
+ return;
+}
+
+sub _close_spool {
+ my $self = shift;
+ my ($parser) = @_;
+
+ if ( my $spool_handle = $parser->delete_spool ) {
+ close($spool_handle)
+ or $self->_croak(" Error closing TAP spool file( $! ) \n ");
+ }
+
+ return;
+}
+
+sub _croak {
+ my ( $self, $message ) = @_;
+ unless ($message) {
+ $message = $self->_error;
+ }
+ $self->SUPER::_croak($message);
+
+ return;
+}
+
+=head1 REPLACING
+
+If you like the C<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> has a fairly rich set of arguments. You'll probably want
+to read over this code carefully to see how all of them are being used.
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
diff --git a/Master/tlpkg/tlperl/lib/TAP/Object.pm b/Master/tlpkg/tlperl/lib/TAP/Object.pm
new file mode 100644
index 00000000000..498bb805c91
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Object.pm
@@ -0,0 +1,139 @@
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ package TAP::Whatever;
+
+ use strict;
+ use vars qw(@ISA);
+
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
+
+ # new() implementation by TAP::Object
+ sub _initialize {
+ my ( $self, @args) = @_;
+ # initialize your object
+ return $self;
+ }
+
+ # ... later ...
+ my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes. Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object. Any arguments passed to C<new> will be passed on to the
+L</_initialize> method. Returns a new object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object. This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception. See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+ return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+ $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+ $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+ return;
+}
+
+=head3 C<_construct>
+
+Create a new instance of the specified class.
+
+=cut
+
+sub _construct {
+ my ( $self, $class, @args ) = @_;
+
+ $self->_croak("Bad module name $class")
+ unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
+
+ unless ( $class->can('new') ) {
+ local $@;
+ eval "require $class";
+ $self->_croak("Can't load $class") if $@;
+ }
+
+ return $class->new(@args);
+}
+
+=head3 C<mk_methods>
+
+Create simple getter/setters.
+
+ __PACKAGE__->mk_methods(@method_names);
+
+=cut
+
+sub mk_methods {
+ my ( $class, @methods ) = @_;
+ foreach my $method_name (@methods) {
+ my $method = "${class}::$method_name";
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method_name} = shift if @_;
+ return $self->{$method_name};
+ };
+ }
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser.pm b/Master/tlpkg/tlperl/lib/TAP/Parser.pm
new file mode 100644
index 00000000000..ea3acd907ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser.pm
@@ -0,0 +1,1873 @@
+package TAP::Parser;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
+
+use Carp qw( confess );
+
+=head1 NAME
+
+TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+my $DEFAULT_TAP_VERSION = 12;
+my $MAX_TAP_VERSION = 13;
+
+$ENV{TAP_VERSION} = $MAX_TAP_VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{TAP_VERSION};
+}
+
+BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
+ __PACKAGE__->mk_methods(
+ qw(
+ _stream
+ _spool
+ exec
+ exit
+ is_good_plan
+ plan
+ tests_planned
+ tests_run
+ wait
+ version
+ in_todo
+ start_time
+ end_time
+ skip_all
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ )
+ );
+} # done making accessors
+
+=head1 SYNOPSIS
+
+ use TAP::Parser;
+
+ my $parser = TAP::Parser->new( { source => $source } );
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser> is designed to produce a proper parse of TAP output. For
+an example of how to run tests through this module, see the simple
+harnesses C<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
+
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
+
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
+
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
+
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
+
+=item * C<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> method is used:
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+=item * C<switches>
+
+If using a Perl file as a source, optional switches may be passed which will
+be used when invoking the perl executable.
+
+ my $parser = TAP::Parser->new( {
+ source => $test_file,
+ switches => '-Ilib',
+ } );
+
+=item * C<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+If false, STDERR is not captured (though it is 'relayed' to keep it
+somewhat synchronized with STDOUT.)
+
+If true, STDERR and STDOUT are the same filehandle. This may cause
+breakage if STDERR contains anything resembling TAP format, but does
+allow exact synchronization.
+
+Subtleties of this behavior may be platform-dependent and may change in
+the future.
+
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use. It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use. It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use. It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
+=back
+
+=cut
+
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class {'TAP::Parser::Source'}
+sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
+sub _default_grammar_class {'TAP::Parser::Grammar'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ my $parser = TAP::Parser->new( { source => $file } );
+ while ( my $result = $parser->next ) {
+ print $result->as_string, "\n";
+ }
+
+This method returns the results of the parsing, one result at a time. Note
+that it is destructive. You can't rewind and examine previous results.
+
+If callbacks are used, they will be issued before this call returns.
+
+Each result returned is a subclass of L<TAP::Parser::Result>. See that
+module and related classes for more information on how to use them.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+##############################################################################
+
+=head3 C<run>
+
+ $parser->run;
+
+This method merely runs the parser and parses all of the TAP.
+
+=cut
+
+sub run {
+ my $self = shift;
+ while ( defined( my $result = $self->next ) ) {
+
+ # do nothing
+ }
+}
+
+##############################################################################
+
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it. Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_source { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+ my ( $self, $source ) = @_;
+
+ # If the source has a get_stream method then use it. This makes it
+ # possible to pass a pre-existing source object to the parser's
+ # constructor.
+ if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+ return $source->get_stream($self);
+ }
+ else {
+ return $self->iterator_factory_class->make_iterator($source);
+ }
+}
+
+{
+
+ # of the following, anything beginning with an underscore is strictly
+ # internal and should not be exposed.
+ my %initialize = (
+ version => $DEFAULT_TAP_VERSION,
+ plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
+ tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
+ skipped => [], #
+ todo => [], #
+ passed => [], #
+ failed => [], #
+ actual_failed => [], # how many tests really failed
+ actual_passed => [], # how many tests really passed
+ todo_passed => [], # tests which unexpectedly succeed
+ parse_errors => [], # perfect TAP should have none
+ );
+
+ # We seem to have this list hanging around all over the place. We could
+ # probably get it from somewhere else to avoid the repetition.
+ my @legal_callback = qw(
+ test
+ version
+ plan
+ comment
+ bailout
+ unknown
+ yaml
+ ALL
+ ELSE
+ EOF
+ );
+
+ my @class_overrides = qw(
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ );
+
+ sub _initialize {
+ my ( $self, $arg_for ) = @_;
+
+ # everything here is basically designed to convert any TAP source to a
+ # stream.
+
+ # Shallow copy
+ my %args = %{ $arg_for || {} };
+
+ $self->SUPER::_initialize( \%args, \@legal_callback );
+
+ # get any class overrides out first:
+ for my $key (@class_overrides) {
+ my $default_method = "_default_$key";
+ my $val = delete $args{$key} || $self->$default_method();
+ $self->$key($val);
+ }
+
+ my $stream = delete $args{stream};
+ my $tap = delete $args{tap};
+ my $source = delete $args{source};
+ my $exec = delete $args{exec};
+ my $merge = delete $args{merge};
+ my $spool = delete $args{spool};
+ my $switches = delete $args{switches};
+ my $ignore_exit = delete $args{ignore_exit};
+ my @test_args = @{ delete $args{test_args} || [] };
+
+ if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
+ $self->_croak(
+ "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
+ );
+ }
+
+ if ( my @excess = sort keys %args ) {
+ $self->_croak("Unknown options: @excess");
+ }
+
+ if ($tap) {
+ $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
+ }
+ elsif ($exec) {
+ my $source = $self->make_source;
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream($self);
+ }
+ elsif ($source) {
+ if ( $source =~ /\n/ ) {
+ $stream
+ = $self->_iterator_for_source( [ split "\n" => $source ] );
+ }
+ elsif ( ref $source ) {
+ $stream = $self->_iterator_for_source($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source;
+
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream($self);
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
+ }
+
+ unless ($stream) {
+ $self->_croak('PANIC: could not determine stream');
+ }
+
+ while ( my ( $k, $v ) = each %initialize ) {
+ $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
+ }
+
+ $self->_stream($stream);
+ $self->_spool($spool);
+ $self->ignore_exit($ignore_exit);
+
+ return $self;
+ }
+}
+
+=head1 INDIVIDUAL RESULTS
+
+If you've read this far in the docs, you've seen this:
+
+ while ( my $result = $parser->next ) {
+ print $result->as_string;
+ }
+
+Each result returned is a L<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=head2 Result types
+
+Basically, you fetch individual results from the TAP. The six types, with
+examples of each, are as follows:
+
+=over 4
+
+=item * Version
+
+ TAP version 12
+
+=item * Plan
+
+ 1..42
+
+=item * Pragma
+
+ pragma +strict
+
+=item * Test
+
+ ok 3 - We should start with some foobar!
+
+=item * Comment
+
+ # Hope we don't use up the foobar.
+
+=item * Bailout
+
+ Bail out! We ran out of foobar!
+
+=item * Unknown
+
+ ... yo, this ain't TAP! ...
+
+=back
+
+Each result fetched is a result object of a different type. There are common
+methods to each result object and different types may have methods unique to
+their type. Sometimes a type method may be overridden in a subclass, but its
+use is guaranteed to be identical.
+
+=head2 Common type methods
+
+=head3 C<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+Indicates whether or not this is a comment. Comments will generally only
+appear in the TAP stream if STDERR is merged to STDOUT. See the
+C<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut
+which allows you to do this:
+
+ my $parser = TAP::Parser->new( { source => $source } );
+ while ( my $result = $parser->next ) {
+ # only print failing results
+ print $result->as_string unless $result->is_ok;
+ }
+
+=head2 C<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<pragma> methods
+
+ if ( $result->is_pragma ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<pragmas>
+
+Returns a list of pragmas each of which is a + or - followed by the
+pragma name.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=head2 C<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+B<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ if ( $parser->in_todo ) { ... }
+
+True while the most recent result was a TODO. Becomes true before the
+TODO result is returned and stays true until just before the next non-
+TODO test is returned.
+
+=head1 TOTAL RESULTS
+
+After parsing the TAP, there are many methods available to let you dig through
+the results and determine what is meaningful to you.
+
+=head2 Individual Results
+
+These results refer to individual tests which are run.
+
+=head3 C<passed>
+
+ my @passed = $parser->passed; # the test numbers which passed
+ my $passed = $parser->passed; # the number of tests which passed
+
+This method lets you know which (or how many) tests passed. If a test failed
+but had a TODO directive, it will be counted as a passed test.
+
+=cut
+
+sub passed { @{ shift->{passed} } }
+
+=head3 C<failed>
+
+ my @failed = $parser->failed; # the test numbers which failed
+ my $failed = $parser->failed; # the number of tests which failed
+
+This method lets you know which (or how many) tests failed. If a test passed
+but had a TODO directive, it will B<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # the test numbers which actually passed
+ my @actual_passed = $parser->actual_passed;
+
+ # the number of tests which actually passed
+ my $actual_passed = $parser->actual_passed;
+
+This method lets you know which (or how many) tests actually passed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_passed { @{ shift->{actual_passed} } }
+*actual_ok = \&actual_passed;
+
+=head3 C<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # the test numbers which actually failed
+ my @actual_failed = $parser->actual_failed;
+
+ # the number of tests which actually failed
+ my $actual_failed = $parser->actual_failed;
+
+This method lets you know which (or how many) tests actually failed,
+regardless of whether or not a TODO directive was found.
+
+=cut
+
+sub actual_failed { @{ shift->{actual_failed} } }
+
+##############################################################################
+
+=head3 C<todo>
+
+ my @todo = $parser->todo; # the test numbers with todo directives
+ my $todo = $parser->todo; # the number of tests with todo directives
+
+This method lets you know which (or how many) tests had TODO directives.
+
+=cut
+
+sub todo { @{ shift->{todo} } }
+
+=head3 C<todo_passed>
+
+ # the test numbers which unexpectedly succeeded
+ my @todo_passed = $parser->todo_passed;
+
+ # the number of tests which unexpectedly succeeded
+ my $todo_passed = $parser->todo_passed;
+
+This method lets you know which (or how many) tests actually passed but were
+declared as "TODO" tests.
+
+=cut
+
+sub todo_passed { @{ shift->{todo_passed} } }
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ my @skipped = $parser->skipped; # the test numbers with SKIP directives
+ my $skipped = $parser->skipped; # the number of tests with SKIP directives
+
+This method lets you know which (or how many) tests had SKIP directives.
+
+=cut
+
+sub skipped { @{ shift->{skipped} } }
+
+=head2 Pragmas
+
+=head3 C<pragma>
+
+Get or set a pragma. To get the state of a pragma:
+
+ if ( $p->pragma('strict') ) {
+ # be strict
+ }
+
+To set the state of a pragma:
+
+ $p->pragma('strict', 1); # enable strict mode
+
+=cut
+
+sub pragma {
+ my ( $self, $pragma ) = splice @_, 0, 2;
+
+ return $self->{pragma}->{$pragma} unless @_;
+
+ if ( my $state = shift ) {
+ $self->{pragma}->{$pragma} = 1;
+ }
+ else {
+ delete $self->{pragma}->{$pragma};
+ }
+
+ return;
+}
+
+=head3 C<pragmas>
+
+Get a list of all the currently enabled pragmas:
+
+ my @pragmas_enabled = $p->pragmas;
+
+=cut
+
+sub pragmas { sort keys %{ shift->{pragma} || {} } }
+
+=head2 Summary Results
+
+These results are "meta" information about the total results of an individual
+test program.
+
+=head3 C<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ if ( $parser->is_good_plan ) { ... }
+
+Returns a boolean value indicating whether or not the number of tests planned
+matches the number of tests run.
+
+B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ print $parser->tests_planned;
+
+Returns the number of tests planned, according to the plan. For example, a
+plan of '1..17' will mean that 17 tests were planned.
+
+=head3 C<tests_run>
+
+ print $parser->tests_run;
+
+Returns the number of tests which actually were run. Hopefully this will
+match the number of C<< $parser->tests_planned >>.
+
+=head3 C<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+This is a 'catch-all' method which returns true if any tests have currently
+failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
+}
+
+=head3 C<version>
+
+ $parser->version;
+
+Once the parser is done, this will return the version number for the
+parsed TAP. Version numbers were introduced with TAP version 13 so if no
+version number is found version 12 is assumed.
+
+=head3 C<exit>
+
+ $parser->exit;
+
+Once the parser is done, this will return the exit status. If the parser ran
+an executable, it returns the exit status of the executable.
+
+=head3 C<wait>
+
+ $parser->wait;
+
+Once the parser is done, this will return the wait status. If the parser ran
+an executable, it returns the wait status of the executable. Otherwise, this
+mererely returns the C<exit> status.
+
+=head2 C<ignore_exit>
+
+ $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
+=head3 C<parse_errors>
+
+ my @errors = $parser->parse_errors; # the parser errors
+ my $errors = $parser->parse_errors; # the number of parser_errors
+
+Fortunately, all TAP output is perfect. In the event that it is not, this
+method will return parser errors. Note that a junk line which the parser does
+not recognize is C<not> an error. This allows this parser to handle future
+versions of TAP. The following are all TAP errors reported by the parser:
+
+=over 4
+
+=item * Misplaced plan
+
+The plan (for example, '1..5'), must only come at the beginning or end of the
+TAP output.
+
+=item * No plan
+
+Gotta have a plan!
+
+=item * More than one plan
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+ 1..3
+
+Right. Very funny. Don't do that.
+
+=item * Test numbers out of sequence
+
+ 1..3
+ ok 1 - input file opened
+ not ok 2 - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+That last test line above should have the number '3' instead of '2'.
+
+Note that it's perfectly acceptable for some lines to have test numbers and
+others to not have them. However, when a test number is found, it must be in
+sequence. The following is also an error:
+
+ 1..3
+ ok 1 - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 2 read the rest of the file
+
+But this is not:
+
+ 1..3
+ ok - input file opened
+ not ok - first line of the input valid # todo some data
+ ok 3 read the rest of the file
+
+=back
+
+=cut
+
+sub parse_errors { @{ shift->{parse_errors} } }
+
+sub _add_error {
+ my ( $self, $error ) = @_;
+ push @{ $self->{parse_errors} } => $error;
+ return $self;
+}
+
+sub _make_state_table {
+ my $self = shift;
+ my %states;
+ my %planned_todo = ();
+
+ # These transitions are defaults for all states
+ my %state_globals = (
+ comment => {},
+ bailout => {},
+ yaml => {},
+ version => {
+ act => sub {
+ $self->_add_error(
+ 'If TAP version is present it must be the first line of output'
+ );
+ },
+ },
+ unknown => {
+ act => sub {
+ my $unk = shift;
+ if ( $self->pragma('strict') ) {
+ $self->_add_error(
+ 'Unknown TAP token: "' . $unk->raw . '"' );
+ }
+ },
+ },
+ pragma => {
+ act => sub {
+ my ($pragma) = @_;
+ for my $pr ( $pragma->pragmas ) {
+ if ( $pr =~ /^ ([-+])(\w+) $/x ) {
+ $self->pragma( $2, $1 eq '+' );
+ }
+ }
+ },
+ },
+ );
+
+ # Provides default elements for transitions
+ my %state_defaults = (
+ plan => {
+ act => sub {
+ my ($plan) = @_;
+ $self->tests_planned( $plan->tests_planned );
+ $self->plan( $plan->plan );
+ if ( $plan->has_skip ) {
+ $self->skip_all( $plan->explanation
+ || '(no reason given)' );
+ }
+
+ $planned_todo{$_}++ for @{ $plan->todo_list };
+ },
+ },
+ test => {
+ act => sub {
+ my ($test) = @_;
+
+ my ( $number, $tests_run )
+ = ( $test->number, ++$self->{tests_run} );
+
+ # Fake TODO state
+ if ( defined $number && delete $planned_todo{$number} ) {
+ $test->set_directive('TODO');
+ }
+
+ my $has_todo = $test->has_todo;
+
+ $self->in_todo($has_todo);
+ if ( defined( my $tests_planned = $self->tests_planned ) ) {
+ if ( $tests_run > $tests_planned ) {
+ $test->is_unplanned(1);
+ }
+ }
+
+ if ( defined $number ) {
+ if ( $number != $tests_run ) {
+ my $count = $tests_run;
+ $self->_add_error( "Tests out of sequence. Found "
+ . "($number) but expected ($count)" );
+ }
+ }
+ else {
+ $test->_number( $number = $tests_run );
+ }
+
+ push @{ $self->{todo} } => $number if $has_todo;
+ push @{ $self->{todo_passed} } => $number
+ if $test->todo_passed;
+ push @{ $self->{skipped} } => $number
+ if $test->has_skip;
+
+ push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
+ $number;
+ push @{
+ $self->{
+ $test->is_actual_ok
+ ? 'actual_passed'
+ : 'actual_failed'
+ }
+ } => $number;
+ },
+ },
+ yaml => { act => sub { }, },
+ );
+
+ # Each state contains a hash the keys of which match a token type. For
+ # each token
+ # type there may be:
+ # act A coderef to run
+ # goto The new state to move to. Stay in this state if
+ # missing
+ # continue Goto the new state and run the new state for the
+ # current token
+ %states = (
+ INIT => {
+ version => {
+ act => sub {
+ my ($version) = @_;
+ my $ver_num = $version->version;
+ if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
+ my $ver_min = $DEFAULT_TAP_VERSION + 1;
+ $self->_add_error(
+ "Explicit TAP version must be at least "
+ . "$ver_min. Got version $ver_num" );
+ $ver_num = $DEFAULT_TAP_VERSION;
+ }
+ if ( $ver_num > $MAX_TAP_VERSION ) {
+ $self->_add_error(
+ "TAP specified version $ver_num but "
+ . "we don't know about versions later "
+ . "than $MAX_TAP_VERSION" );
+ $ver_num = $MAX_TAP_VERSION;
+ }
+ $self->version($ver_num);
+ $self->_grammar->set_version($ver_num);
+ },
+ goto => 'PLAN'
+ },
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLAN => {
+ plan => { goto => 'PLANNED' },
+ test => { goto => 'UNPLANNED' },
+ },
+ PLANNED => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => {
+ act => sub {
+ my ($version) = @_;
+ $self->_add_error(
+ 'More than one plan found in TAP output');
+ },
+ },
+ },
+ PLANNED_AFTER_TEST => {
+ test => { goto => 'PLANNED_AFTER_TEST' },
+ plan => { act => sub { }, continue => 'PLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ GOT_PLAN => {
+ test => {
+ act => sub {
+ my ($plan) = @_;
+ my $line = $self->plan;
+ $self->_add_error(
+ "Plan ($line) must be at the beginning "
+ . "or end of the TAP output" );
+ $self->is_good_plan(0);
+ },
+ continue => 'PLANNED'
+ },
+ plan => { continue => 'PLANNED' },
+ },
+ UNPLANNED => {
+ test => { goto => 'UNPLANNED_AFTER_TEST' },
+ plan => { goto => 'GOT_PLAN' },
+ },
+ UNPLANNED_AFTER_TEST => {
+ test => { act => sub { }, continue => 'UNPLANNED' },
+ plan => { act => sub { }, continue => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
+ },
+ );
+
+ # Apply globals and defaults to state table
+ for my $name ( keys %states ) {
+
+ # Merge with globals
+ my $st = { %state_globals, %{ $states{$name} } };
+
+ # Add defaults
+ for my $next ( sort keys %{$st} ) {
+ if ( my $default = $state_defaults{$next} ) {
+ for my $def ( sort keys %{$default} ) {
+ $st->{$next}->{$def} ||= $default->{$def};
+ }
+ }
+ }
+
+ # Stuff back in table
+ $states{$name} = $st;
+ }
+
+ return \%states;
+}
+
+=head3 C<get_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _grammar {
+ my $self = shift;
+ return $self->{_grammar} = shift if @_;
+
+ return $self->{_grammar} ||= $self->make_grammar(
+ { stream => $self->_stream,
+ parser => $self,
+ version => $self->version
+ }
+ );
+}
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $grammar = $self->_grammar;
+ my $spool = $self->_spool;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ $self->start_time( $self->get_time );
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ else {
+ confess("Unhandled token type: $type\n");
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $self )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # Avoid leaks
+ $self->_stream(undef);
+ $self->_grammar(undef);
+
+ # If we just delete the iter we won't get a fault if it's recreated.
+ # Instead we set it to a sub that returns an infinite
+ # stream of undef. This segfaults on 5.5.4, presumably because
+ # we're still executing the closure that gets replaced and it hasn't
+ # been protected with a refcount.
+ $self->{_iter} = sub {return}
+ if $] >= 5.006;
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ my %callbacks = (
+ test => \&test_callback,
+ plan => \&plan_callback,
+ comment => \&comment_callback,
+ bailout => \&bailout_callback,
+ unknown => \&unknown_callback,
+ );
+
+ my $aggregator = TAP::Parser::Aggregator->new;
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new(
+ {
+ source => $file,
+ callbacks => \%callbacks,
+ }
+ );
+ $parser->run;
+ $aggregator->add( $file, $parser );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods. That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability. If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a I<source>. There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>. There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
+
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>. There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic. Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results. If you need to customize its behaviour
+you should probably familiarize yourself with the source first. Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter. See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=item * David Wheeler
+
+=item * Alex Vandiver
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+Steve Purkis <spurkis@cpan.org>
+
+Nicholas Clark <nick@ccl4.org>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm
new file mode 100644
index 00000000000..10b37ef72a3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm
@@ -0,0 +1,416 @@
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+ $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+ # Slightly nasty. Instead we should maybe have 'cooked' accessors
+ # for results that may be masked by the parser.
+ next
+ if ( $method eq 'exit' || $method eq 'wait' )
+ && $parser->ignore_exit;
+
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to
+the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return
+ $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * planned
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse errors
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return
+ $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm
new file mode 100644
index 00000000000..44f28a0491e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm
@@ -0,0 +1,580 @@
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::YAMLish::Reader ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Grammar;
+ my $grammar = $self->make_grammar({
+ stream => $tap_parser_stream,
+ parser => $tap_parser,
+ version => 12,
+ });
+
+ my $result = $grammar->tokenize;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $grammar = TAP::Parser::Grammar->new({
+ stream => $stream,
+ parser => $parser,
+ version => $version,
+ });
+
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments. If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
+
+=cut
+
+# new() implementation supplied by TAP::Object
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{stream} = $args->{stream}; # TODO: accessor
+ $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->set_version( $args->{version} || 12 );
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+
+ # If we can't match # SKIP the directive should be undef.
+ ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ pragma => {
+ syntax =>
+ qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $pragmas = $1;
+ return $self->_make_pragma_token( $line, $pragmas );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{stream}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{version} = $version;
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{stream}->next;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
+
+ my $token;
+
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return $self->{parser}->make_result($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ foreach my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP'
+ && 0 != $tests_planned
+ && $self->{version} < 13 )
+ {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ return {
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => ( defined $dir ? uc $dir : '' ),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ };
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $stream = $self->{stream};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $stream->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _make_pragma_token {
+ my ( $self, $line, $pragmas ) = @_;
+ return {
+ type => 'pragma',
+ raw => $line,
+ pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+1;
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code. There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm
new file mode 100644
index 00000000000..09d40bebccb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm
@@ -0,0 +1,165 @@
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for general usage
+
+ # to subclass:
+ use vars qw(@ISA);
+ use TAP::Parser::Iterator ();
+ @ISA = qw(TAP::Parser::Iterator);
+ sub _initialize {
+ # see TAP::Object...
+ }
+
+=head1 DESCRIPTION
+
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Provided by L<TAP::Object>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+B<Note:> this method is abstract and should be overridden.
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+sub next_raw {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+The default implementation does nothing.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+ return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
+
+=cut
+
+sub wait {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+sub exit {
+ require Carp;
+ my $msg = Carp::longmess('abstract method called directly!');
+ $_[0]->_croak($msg);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm
new file mode 100644
index 00000000000..1513d5b9945
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm
@@ -0,0 +1,106 @@
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Array;
+ my @data = ('foo', 'bar', baz');
+ my $it = TAP::Parser::Iterator::Array->new(\@data);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Takes one argument: an C<$array_ref>
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ chomp @$thing;
+ $self->{idx} = 0;
+ $self->{array} = $thing;
+ $self->{exit} = undef;
+ return $self;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm
new file mode 100644
index 00000000000..a0a5a8ed32e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm
@@ -0,0 +1,377 @@
+package TAP::Parser::Iterator::Process;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+use Config;
+use IO::Handle;
+
+@ISA = 'TAP::Parser::Iterator';
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Process;
+ my %args = (
+ command => ['python', 'setup.py', 'test'],
+ merge => 1,
+ setup => sub { ... },
+ teardown => sub { ... },
+ );
+ my $it = TAP::Parser::Iterator::Process->new(\%args);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a hashref of the form:
+
+ command => \@command_to_execute
+ merge => $attempt_merge_stderr_and_stdout?
+ setup => $callback_to_setup_command
+ teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available. Falls back onto C<open()>.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through the process output, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $self->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ $self->{out} = $out;
+ $self->{err} = $err;
+ $self->{sel} = $sel;
+ $self->{pid} = $pid;
+ $self->{exit} = undef;
+ $self->{chunk_size} = $chunk_size;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # Avoid circular refs
+ $self->{_next} = sub {return}
+ if $] >= 5.006;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm
new file mode 100644
index 00000000000..c92cbabe089
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm
@@ -0,0 +1,112 @@
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
+ use TAP::Parser::Iterator::Stream;
+ open( TEST, 'test.tap' );
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+ my $line = $it->next;
+
+=head1 DESCRIPTION
+
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator. Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $thing ) = @_;
+ $self->{fh} = $thing;
+ return $self;
+}
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm
new file mode 100644
index 00000000000..064d7beb167
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm
@@ -0,0 +1,171 @@
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::IteratorFactory;
+ my $factory = TAP::Parser::IteratorFactory->new;
+ my $iter = $factory->make_iterator(\*TEST);
+ my $iter = $factory->make_iterator(\@array);
+ my $iter = $factory->make_iterator(\%hash);
+
+ my $line = $iter->next;
+
+=head1 DESCRIPTION
+
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes. Unless you're subclassing, you probably won't need to use this
+module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_iterator>
+
+Create an iterator. The type of iterator created depends on the arguments to
+the constructor:
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
+
+Creates a I<stream> iterator (see L</make_stream_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
+
+Creates an I<array> iterator (see L</make_array_iterator>).
+
+ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
+
+Creates a I<process> iterator (see L</make_process_iterator>).
+
+=cut
+
+sub make_iterator {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return $proto->make_stream_iterator($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return $proto->make_array_iterator($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return $proto->make_process_iterator($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+=head3 C<make_stream_iterator>
+
+Make a new stream iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
+
+=head3 C<make_array_iterator>
+
+Make a new array iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
+
+=head3 C<make_process_iterator>
+
+Make a new process iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+sub make_stream_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Stream->new(@_);
+}
+
+sub make_array_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Array->new(@_);
+}
+
+sub make_process_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Process->new(@_);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=back
+
+=head2 Example
+
+ package MyIteratorFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyStreamIterator;
+ use TAP::Parser::IteratorFactory;
+
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override stream iterator
+ sub make_stream_iterator {
+ my $proto = shift;
+ MyStreamIterator->new(@_);
+ }
+
+ 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm
new file mode 100644
index 00000000000..2e5d9296888
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm
@@ -0,0 +1,195 @@
+package TAP::Parser::Multiplexer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use IO::Select;
+use TAP::Object ();
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+@ISA = 'TAP::Object';
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my $self = shift;
+ $self->{select} = IO::Select->new;
+ $self->{avid} = []; # Parsers that can't select
+ $self->{count} = 0;
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm
new file mode 100644
index 00000000000..b01e95c5d9a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm
@@ -0,0 +1,300 @@
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+
+BEGIN {
+
+ # make is_* methods
+ my @attrs = qw( plan pragma test comment bailout version unknown yaml );
+ no strict 'refs';
+ for my $token (@attrs) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - Base class for TAP::Parser output objects
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ # abstract class - not meany to be used directly
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # directly:
+ use TAP::Parser::Result;
+ my $token = {...};
+ my $result = TAP::Parser::Result->new( $token );
+
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line). Unless you're subclassing, you probably won't need to use this module
+directly.
+
+=head2 METHODS
+
+=head3 C<new>
+
+ # see TAP::Parser::ResultFactory for preferred usage
+
+ # to use directly:
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+# new() implementation provided by TAP::Object
+
+sub _initialize {
+ my ( $self, $token ) = @_;
+ if ($token) {
+
+ # assign to a hash slice to make a shallow copy of the token.
+ # I guess we could assign to the hash as (by default) there are not
+ # contents, but that seems less helpful if someone wants to subclass us
+ @{$self}{ keys %$token } = values %$token;
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_pragma>
+
+Indicates whether or not this is a pragma line.
+
+ pragma +strict
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ ok 1 Is OK!
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+Prints a string representation of the token. This might not be the exact
+output, however. Tests will have test numbers added if not present, TODO and
+SKIP directives will be capitalized and, in general, things will be cleaned
+up. If you need the original text for the token, see the C<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+ package MyResult;
+
+ use strict;
+ use vars '@ISA';
+
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::Parser::Result::YAML>,
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm
new file mode 100644
index 00000000000..3e42f4110fd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ if ( $result->is_bailout ) {
+ my $explanation = $result->explanation;
+ print "We bailed out because ($explanation)";
+ }
+
+If, and only if, a token is a bailout token, you can get an "explanation" via
+this method. The explanation is the text after the mystical "Bail out!" words
+which appear in the tap output.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm
new file mode 100644
index 00000000000..1e9ba13c5f2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm
@@ -0,0 +1,61 @@
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm
new file mode 100644
index 00000000000..67c01df200d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm
@@ -0,0 +1,120 @@
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ my $planned = $result->tests_planned;
+
+Returns the number of tests planned. For example, a plan of C<1..17> will
+cause this method to return '17'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm
new file mode 100644
index 00000000000..3eb62b3322b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Pragma;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Pragma - TAP pragma token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a pragma is encountered.
+
+ TAP version 13
+ pragma +strict, -foo
+
+Pragmas are only supported from TAP version 13 onwards.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<pragmas>
+
+if ( $result->is_pragma ) {
+ @pragmas = $result->pragmas;
+}
+
+=cut
+
+sub pragmas {
+ my @pragmas = @{ shift->{pragmas} };
+ return wantarray ? @pragmas : \@pragmas;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm
new file mode 100644
index 00000000000..11cf302de6a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm
@@ -0,0 +1,274 @@
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explantion, if present.
+
+ not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
+
+This was a badly misnamed method. It indicates which TODO tests unexpectedly
+succeeded. Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm
new file mode 100644
index 00000000000..52e19585d9a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm
@@ -0,0 +1,51 @@
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm
new file mode 100644
index 00000000000..b97681eb065
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm
@@ -0,0 +1,63 @@
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP syntax version token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 13
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 13.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm
new file mode 100644
index 00000000000..ada3ae445bb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm
@@ -0,0 +1,62 @@
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm
new file mode 100644
index 00000000000..46d0df29dbd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm
@@ -0,0 +1,189 @@
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Pragma ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::ResultFactory;
+ my $token = {...};
+ my $factory = TAP::Parser::ResultFactory->new;
+ my $result = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+ my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+ my ( $proto, $token ) = @_;
+ my $type = $token->{type};
+ return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+ # create a custom result type:
+ package MyResult;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
+
+ # register with the factory:
+ TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+ # use it:
+ my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
+
+sub class_for {
+ my ( $class, $type ) = @_;
+
+ # return target class:
+ return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+ # or complain:
+ require Carp;
+ Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+ my ( $class, $type, $rclass ) = @_;
+
+ # register it blindly, assume they know what they're doing
+ $CLASS_FOR{$type} = $rclass;
+ return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+ package MyFooResult;
+ TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+ package MyResultFactory;
+
+ use strict;
+ use vars '@ISA';
+
+ use MyResult;
+ use TAP::Parser::ResultFactory;
+
+ @ISA = qw( TAP::Parser::ResultFactory );
+
+ # force all results to be 'MyResult'
+ sub class_for {
+ return 'MyResult';
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm
new file mode 100644
index 00000000000..f1817093af0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm
@@ -0,0 +1,312 @@
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ croak "Need a number of key, value pairs" if @_ % 2;
+
+ my %args = @_;
+ my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+ my $rules = delete $args{rules} || { par => '**' };
+
+ croak "Unknown arg(s): ", join ', ', sort keys %args
+ if keys %args;
+
+ # Turn any simple names into a name, description pair. TODO: Maybe
+ # construct jobs here?
+ my $self = bless {}, $class;
+
+ $self->_set_rules( $rules, $tests );
+
+ return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+# || ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+ my ( $self, $rules, $tests ) = @_;
+ my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+ map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+ my $schedule = $self->_rule_clause( $rules, \@tests );
+
+ # If any tests are left add them as a sequential block at the end of
+ # the run.
+ $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+ $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+ my ( $self, $rule, $tests ) = @_;
+ croak 'Rule clause must be a hash'
+ unless 'HASH' eq ref $rule;
+
+ my @type = keys %$rule;
+ croak 'Rule clause must have exactly one key'
+ unless @type == 1;
+
+ my %handlers = (
+ par => sub {
+ [ map { [$_] } @_ ];
+ },
+ seq => sub { [ [@_] ] },
+ );
+
+ my $handler = $handlers{ $type[0] }
+ || croak 'Unknown scheduler type: ', $type[0];
+ my $val = $rule->{ $type[0] };
+
+ return $handler->(
+ map {
+ 'HASH' eq ref $_
+ ? $self->_rule_clause( $_, $tests )
+ : $self->_expand( $_, $tests )
+ } 'ARRAY' eq ref $val ? @$val : $val
+ );
+}
+
+sub _glob_to_regexp {
+ my ( $self, $glob ) = @_;
+ my $nesting;
+ my $pattern;
+
+ while (1) {
+ if ( $glob =~ /\G\*\*/gc ) {
+
+ # ** is any number of characters, including /, within a pathname
+ $pattern .= '.*?';
+ }
+ elsif ( $glob =~ /\G\*/gc ) {
+
+ # * is zero or more characters within a filename/directory name
+ $pattern .= '[^/]*';
+ }
+ elsif ( $glob =~ /\G\?/gc ) {
+
+ # ? is exactly one character within a filename/directory name
+ $pattern .= '[^/]';
+ }
+ elsif ( $glob =~ /\G\{/gc ) {
+
+ # {foo,bar,baz} is any of foo, bar or baz.
+ $pattern .= '(?:';
+ ++$nesting;
+ }
+ elsif ( $nesting and $glob =~ /\G,/gc ) {
+
+ # , is only special inside {}
+ $pattern .= '|';
+ }
+ elsif ( $nesting and $glob =~ /\G\}/gc ) {
+
+ # } that matches { is special. But unbalanced } are not.
+ $pattern .= ')';
+ --$nesting;
+ }
+ elsif ( $glob =~ /\G(\\.)/gc ) {
+
+ # A quoted literal
+ $pattern .= $1;
+ }
+ elsif ( $glob =~ /\G([\},])/gc ) {
+
+ # Sometimes meta characters
+ $pattern .= '\\' . $1;
+ }
+ else {
+
+ # Eat everything that is not a meta character.
+ $glob =~ /\G([^{?*\\\},]*)/gc;
+ $pattern .= quotemeta $1;
+ }
+ return $pattern if pos $glob == length $glob;
+ }
+}
+
+sub _expand {
+ my ( $self, $name, $tests ) = @_;
+
+ my $pattern = $self->_glob_to_regexp($name);
+ $pattern = qr/^ $pattern $/x;
+ my @match = ();
+
+ for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+ if ( $tests->[$ti]->filename =~ $pattern ) {
+ push @match, splice @$tests, $ti, 1;
+ $ti--;
+ }
+ }
+
+ return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+ my $self = shift;
+ my @all = $self->_gather( $self->{schedule} );
+ $self->{count} = @all;
+ @all;
+}
+
+sub _gather {
+ my ( $self, $rule ) = @_;
+ return unless defined $rule;
+ return $rule unless 'ARRAY' eq ref $rule;
+ return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+ my $self = shift;
+ $self->{count} ||= $self->get_all;
+ my @jobs = $self->_find_next_job( $self->{schedule} );
+ if (@jobs) {
+ --$self->{count};
+ return $jobs[0];
+ }
+
+ return TAP::Parser::Scheduler::Spinner->new
+ if $self->{count};
+
+ return;
+}
+
+sub _not_empty {
+ my $ar = shift;
+ return 1 unless 'ARRAY' eq ref $ar;
+ foreach (@$ar) {
+ return 1 if _not_empty($_);
+ }
+ return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+ my ( $self, $rule ) = @_;
+
+ my @queue = ();
+ my $index = 0;
+ while ( $index < @$rule ) {
+ my $seq = $rule->[$index];
+
+ # Prune any exhausted items.
+ shift @$seq while @$seq && _is_empty( $seq->[0] );
+ if (@$seq) {
+ if ( defined $seq->[0] ) {
+ if ( 'ARRAY' eq ref $seq->[0] ) {
+ push @queue, $seq;
+ }
+ else {
+ my $job = splice @$seq, 0, 1, undef;
+ $job->on_finish( sub { shift @$seq } );
+ return $job;
+ }
+ }
+ ++$index;
+ }
+ else {
+
+ # Remove the empty sub-array from the array
+ splice @$rule, $index, 1;
+ }
+ }
+
+ for my $seq (@queue) {
+ if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+ return @jobs;
+ }
+ }
+
+ return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+ my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+ my $pad = ' ' x 2;
+ my $indent = $pad x $depth;
+ if ( !defined $rule ) {
+ return "$indent(undef)\n";
+ }
+ elsif ( 'ARRAY' eq ref $rule ) {
+ return unless @$rule;
+ my $type = ( 'par', 'seq' )[ $depth % 2 ];
+ return join(
+ '', "$indent$type:\n",
+ map { $self->_as_string( $_, $depth + 1 ) } @$rule
+ );
+ }
+ else {
+ return "$indent'" . $rule->filename . "'\n";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm
new file mode 100644
index 00000000000..7ab68f9f673
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm
@@ -0,0 +1,107 @@
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Job->new(
+ $name, $desc
+ );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+ my ( $class, $name, $desc, @ctx ) = @_;
+ return bless {
+ filename => $name,
+ description => $desc,
+ @ctx ? ( context => \@ctx ) : (),
+ }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+ my ( $self, $cb ) = @_;
+ $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( my $cb = $self->{on_finish} ) {
+ $cb->($self);
+ }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename { shift->{filename} }
+sub description { shift->{description} }
+sub context { @{ shift->{context} || [] } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+ my $self = shift;
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm
new file mode 100644
index 00000000000..10af5e33697
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm
@@ -0,0 +1,53 @@
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
new file mode 100644
index 00000000000..9263e9e5442
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm
@@ -0,0 +1,173 @@
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+use TAP::Parser::IteratorFactory ();
+
+@ISA = qw(TAP::Object);
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
+
+=head1 NAME
+
+TAP::Parser::Source - Stream output from some source
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
+
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP. C<croaks> if
+it doesn't get an arrayref.
+
+=cut
+
+sub source {
+ my $self = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>. C<croak>s if there was no command found.
+
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+
+=cut
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyRubySource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source;
+
+ @ISA = qw( TAP::Parser::Source );
+
+ # expect $source->(['mytest.rb', 'cmdline', 'args']);
+ sub source {
+ my ($self, $args) = @_;
+ my ($rb_file) = @$args;
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source::Perl>,
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm
new file mode 100644
index 00000000000..1f4f2e1428c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm
@@ -0,0 +1,326 @@
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+ my ( $self, $factory ) = @_;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Filter out any -I switches to be handled as libs later.
+ #
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ #
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ my @filtered_switches;
+ for (@switches) {
+ if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+ push @libs, $1;
+ }
+ else {
+ push @filtered_switches, $_;
+ }
+ }
+ @switches = @filtered_switches;
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB}
+ = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $previous = $ENV{PERL5LIB};
+ my $teardown = sub {
+ if ( defined $previous ) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
+ push @switches, $self->_libs2switches(@libs);
+ push @switches, split_shell( $ENV{PERL5OPT} );
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if we're VMS, since VMS will downcase anything
+ # not quoted.
+ if (IS_VMS) {
+ for (@switches) {
+ $_ = qq["$_"];
+ }
+ }
+
+ return @switches;
+}
+
+sub _get_perl {
+ my $self = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+ package MyPerlSource;
+
+ use strict;
+ use vars '@ISA';
+
+ use Carp qw( croak );
+ use TAP::Parser::Source::Perl;
+
+ @ISA = qw( TAP::Parser::Source::Perl );
+
+ sub source {
+ my ($self, $args) = @_;
+ if ($args) {
+ $self->{file} = $args->[0];
+ return $self->SUPER::source($args);
+ }
+ return $self->SUPER::source;
+ }
+
+ # use the version of perl from the shebang line in the test file
+ sub _get_perl {
+ my $self = shift;
+ if (my $shebang = $self->shebang( $self->{file} )) {
+ $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+ return $1 if $1;
+ }
+ return $self->SUPER::_get_perl(@_);
+ }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm
new file mode 100644
index 00000000000..a3d2dd1ea98
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm
@@ -0,0 +1,72 @@
+package TAP::Parser::Utils;
+
+use strict;
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( split_shell );
+
+=head1 NAME
+
+TAP::Parser::Utils - Internal TAP::Parser utilities
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Utils qw( split_shell )
+ my @switches = split_shell( $arg );
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+=head2 INTERFACE
+
+=head3 C<split_shell>
+
+Shell style argument parsing. Handles backslash escaping, single and
+double quoted strings but not shell substitutions.
+
+Pass one or more strings containing shell escaped arguments. The return
+value is an array of arguments parsed from the input strings according
+to (approximate) shell parsing rules. It's legal to pass C<undef> in
+which case an empty array will be returned. That makes it possible to
+
+ my @args = split_shell( $ENV{SOME_ENV_VAR} );
+
+without worrying about whether the environment variable exists.
+
+This is used to split HARNESS_PERL_ARGS into individual switches.
+
+=cut
+
+sub split_shell {
+ my @parts = ();
+
+ for my $switch ( grep defined && length, @_ ) {
+ push @parts, $1 while $switch =~ /
+ (
+ (?: [^\\"'\s]+
+ | \\.
+ | " (?: \\. | [^"] )* "
+ | ' (?: \\. | [^'] )* '
+ )+
+ ) /xg;
+ }
+
+ for (@parts) {
+ s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg;
+ }
+
+ return @parts;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm
new file mode 100644
index 00000000000..524d7dca8df
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm
@@ -0,0 +1,333 @@
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# new() implementation supplied by TAP::Object
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ # Prime the reader
+ $self->_next;
+ return unless $self->{next};
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+
+ my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+ push @multiline, $pad . $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($stream);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+Portions copyright 2006-2008 Adam Kennedy.
+
+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.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm
new file mode 100644
index 00000000000..ed81f6d8191
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm
@@ -0,0 +1,255 @@
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# new() implementation supplied by TAP::Object
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+ my $rule = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$rule/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to encode $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.17
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007-2008 Andy Armstrong.
+
+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.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm
new file mode 100644
index 00000000000..1ee7a1ef7ad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/ANSIColor.pm
@@ -0,0 +1,609 @@
+# Term::ANSIColor -- Color screen output using ANSI escape sequences.
+#
+# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009
+# Russ Allbery <rra@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.02';
+
+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 FAINT 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 colorstrip colorvalid);
+ %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 ('', @_);
+ }
+ if ($AUTOLOAD =~ /^([\w:]*::([A-Z_]+))$/ and defined $ATTRIBUTES{lc $2}) {
+ $AUTOLOAD = $1;
+ my $attr = "\e[" . $ATTRIBUTES{lc $2} . '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 $escape");
+ }
+ 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";
+ }
+}
+
+# Given a string, strip the ANSI color codes out of that string and return the
+# result. This removes only ANSI color codes, not movement codes and other
+# escape sequences.
+sub colorstrip {
+ my (@string) = @_;
+ for my $string (@string) {
+ $string =~ s/\e\[[\d;]*m//g;
+ }
+ return wantarray ? @string : join ('', @string);
+}
+
+# Given a list of color attributes (arguments for color, for instance), return
+# true if they're all valid or false if any of them are invalid.
+sub colorvalid {
+ my @codes = map { split } @_;
+ for (@codes) {
+ unless (defined $ATTRIBUTES{lc $_}) {
+ return;
+ }
+ }
+ return 1;
+}
+
+##############################################################################
+# 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(colorstrip);
+ print colorstrip '\e[1mThis is bold\e[0m', "\n";
+
+ use Term::ANSIColor qw(colorvalid);
+ my $valid = colorvalid ('blue bold', 'on_magenta');
+ print "Color string is ", $valid ? "valid\n" : "invalid\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 functions uncolor(),
+colorstrip(), and colorvalid(), which have to be explicitly imported to be
+used (see L</SYNOPSIS>).
+
+=head2 Function Interface
+
+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). color()
+throws an exception if given an invalid attribute, so you can also use it
+to check attribute names for validity (see L</EXAMPLES>).
+
+uncolor() performs the opposite translation, turning escape sequences
+into a list of strings.
+
+colorstrip() removes all color escape sequences from the provided strings,
+returning the modified strings separately in array context or joined
+together in scalar context. Its arguments are not modified.
+
+colorvalid() takes attribute strings the same as color() and returns true
+if all attributes are known and false otherwise.
+
+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.
+
+=head2 Constant Interface
+
+Alternately, if you import C<:constants>, you can use the constants CLEAR,
+RESET, BOLD, DARK, FAINT, 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.
+
+=head2 The Color Stack
+
+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 yes 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@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@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
diff --git a/Master/tlpkg/tlperl/lib/Term/Cap.pm b/Master/tlpkg/tlperl/lib/Term/Cap.pm
new file mode 100644
index 00000000000..004a03c4124
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/Cap.pm
@@ -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@bsdi.com
+# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@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@uiuc.edu
+# Avoid warnings in Tgetent and Tputs
+# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@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@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@cn.ibm.com>
+# Version 1.12: Sat Dec 8 00:10:21 GMT 2007
+# QNX test fix from Matt Kraai <kraai@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@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:
+
diff --git a/Master/tlpkg/tlperl/lib/Term/Complete.pm b/Master/tlpkg/tlperl/lib/Term/Complete.pm
new file mode 100644
index 00000000000..601e4956430
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/Complete.pm
@@ -0,0 +1,188 @@
+package Term::Complete;
+require 5.000;
+require Exporter;
+
+use strict;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(Complete);
+our $VERSION = '1.402';
+
+# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91
+
+=head1 NAME
+
+Term::Complete - Perl word completion module
+
+=head1 SYNOPSIS
+
+ $input = Complete('prompt_string', \@completion_list);
+ $input = Complete('prompt_string', @completion_list);
+
+=head1 DESCRIPTION
+
+This routine provides word completion on the list of words in
+the array (or array ref).
+
+The tty driver is put into raw mode and restored using an operating
+system specific command, in UNIX-like environments C<stty>.
+
+The following command characters are defined:
+
+=over 4
+
+=item E<lt>tabE<gt>
+
+Attempts word completion.
+Cannot be changed.
+
+=item ^D
+
+Prints completion list.
+Defined by I<$Term::Complete::complete>.
+
+=item ^U
+
+Erases the current input.
+Defined by I<$Term::Complete::kill>.
+
+=item E<lt>delE<gt>, E<lt>bsE<gt>
+
+Erases one character.
+Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Bell sounds when word completion fails.
+
+=head1 BUGS
+
+The completion character E<lt>tabE<gt> cannot be changed.
+
+=head1 AUTHOR
+
+Wayne Thompson
+
+=cut
+
+our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore);
+our($tty_saved_state) = '';
+CONFIG: {
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+ foreach my $s (qw(/bin/stty /usr/bin/stty)) {
+ if (-x $s) {
+ $tty_raw_noecho = "$s raw -echo";
+ $tty_restore = "$s -raw echo";
+ $tty_safe_restore = $tty_restore;
+ $stty = $s;
+ last;
+ }
+ }
+}
+
+sub Complete {
+ my($prompt, @cmp_lst, $cmp, $test, $l, @match);
+ my ($return, $r) = ("", 0);
+
+ $return = "";
+ $r = 0;
+
+ $prompt = shift;
+ if (ref $_[0] || $_[0] =~ /^\*/) {
+ @cmp_lst = sort @{$_[0]};
+ }
+ else {
+ @cmp_lst = sort(@_);
+ }
+
+ # Attempt to save the current stty state, to be restored later
+ if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') {
+ $tty_saved_state = qx($stty -g 2>/dev/null);
+ if ($?) {
+ # stty -g not supported
+ $tty_saved_state = undef;
+ }
+ else {
+ $tty_saved_state =~ s/\s+$//g;
+ $tty_restore = qq($stty "$tty_saved_state" 2>/dev/null);
+ }
+ }
+ system $tty_raw_noecho if defined $tty_raw_noecho;
+ LOOP: {
+ local $_;
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^\Q$return/, @cmp_lst);
+ unless ($#match < 0) {
+ $l = length($test = shift(@match));
+ foreach $cmp (@match) {
+ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
+ $l--;
+ }
+ }
+ print("\a");
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
+ }
+ last CASE;
+ };
+
+ # (^D) completion list
+ $_ eq $complete && do {
+ print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ $r = 0;
+ $return = "";
+ print("\r\n");
+ redo LOOP;
+ }
+ last CASE;
+ };
+
+ # (DEL) || (BS) erase
+ ($_ eq $erase1 || $_ eq $erase2) && do {
+ if($r) {
+ print("\b \b");
+ chop($return);
+ $r--;
+ }
+ last CASE;
+ };
+
+ # printable char
+ ord >= 32 && do {
+ $return .= $_;
+ $r++;
+ print;
+ last CASE;
+ };
+ }
+ }
+ }
+
+ # system $tty_restore if defined $tty_restore;
+ if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore)
+ {
+ system $tty_restore;
+ if ($?) {
+ # tty_restore caused error
+ system $tty_safe_restore;
+ }
+ }
+ print("\n");
+ $return;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Term/ReadLine.pm b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
new file mode 100644
index 00000000000..29acb849015
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/ReadLine.pm
@@ -0,0 +1,416 @@
+=head1 NAME
+
+Term::ReadLine - Perl interface to various C<readline> packages.
+If no real package is found, substitutes stubs instead of basic functions.
+
+=head1 SYNOPSIS
+
+ use Term::ReadLine;
+ my $term = Term::ReadLine->new('Simple Perl calc');
+ my $prompt = "Enter your arithmetic expression: ";
+ my $OUT = $term->OUT || \*STDOUT;
+ while ( defined ($_ = $term->readline($prompt)) ) {
+ my $res = eval($_);
+ warn $@ if $@;
+ print $OUT $res, "\n" unless $@;
+ $term->addhistory($_) if /\S/;
+ }
+
+=head1 DESCRIPTION
+
+This package is just a front end to some other packages. It's a stub to
+set up a common interface to the various ReadLine implementations found on
+CPAN (under the C<Term::ReadLine::*> namespace).
+
+=head1 Minimal set of supported functions
+
+All the supported functions should be called as methods, i.e., either as
+
+ $term = Term::ReadLine->new('name');
+
+or as
+
+ $term->addhistory('row');
+
+where $term is a return value of Term::ReadLine-E<gt>new().
+
+=over 12
+
+=item C<ReadLine>
+
+returns the actual package that executes the commands. Among possible
+values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
+C<Term::ReadLine::Stub>.
+
+=item C<new>
+
+returns the handle for subsequent calls to following
+functions. Argument is the name of the application. Optionally can be
+followed by two arguments for C<IN> and C<OUT> filehandles. These
+arguments should be globs.
+
+=item C<readline>
+
+gets an input line, I<possibly> with actual C<readline>
+support. Trailing newline is removed. Returns C<undef> on C<EOF>.
+
+=item C<addhistory>
+
+adds the line to the history of input, from where it can be used if
+the actual C<readline> is present.
+
+=item C<IN>, C<OUT>
+
+return the filehandles for input and output or C<undef> if C<readline>
+input and output cannot be used for Perl.
+
+=item C<MinLine>
+
+If argument is specified, it is an advice on minimal size of line to
+be included into history. C<undef> means do not include anything into
+history. Returns the old value.
+
+=item C<findConsole>
+
+returns an array with two strings that give most appropriate names for
+files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
+
+=item Attribs
+
+returns a reference to a hash which describes internal configuration
+of the package. Names of keys in this hash conform to standard
+conventions with the leading C<rl_> stripped.
+
+=item C<Features>
+
+Returns a reference to a hash with keys being features present in
+current implementation. Several optional features are used in the
+minimal interface: C<appname> should be present if the first argument
+to C<new> is recognized, and C<minline> should be present if
+C<MinLine> method is not dummy. C<autohistory> should be present if
+lines are put into history automatically (maybe subject to
+C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
+
+If C<Features> method reports a feature C<attribs> as present, the
+method C<Attribs> is not dummy.
+
+=back
+
+=head1 Additional supported functions
+
+Actually C<Term::ReadLine> can use some other package, that will
+support a richer set of commands.
+
+All these commands are callable via method interface and have names
+which conform to standard conventions with the leading C<rl_> stripped.
+
+The stub package included with the perl distribution allows some
+additional methods:
+
+=over 12
+
+=item C<tkRunning>
+
+makes Tk event loop run when waiting for user input (i.e., during
+C<readline> method).
+
+=item C<ornaments>
+
+makes the command line stand out by using termcap data. The argument
+to C<ornaments> should be 0, 1, or a string of a form
+C<"aa,bb,cc,dd">. Four components of this string should be names of
+I<terminal capacities>, first two will be issued to make the prompt
+standout, last two to make the input line standout.
+
+=item C<newTTY>
+
+takes two arguments which are input filehandle and output filehandle.
+Switches to use these filehandles.
+
+=back
+
+One can check whether the currently loaded ReadLine package supports
+these methods by checking for corresponding C<Features>.
+
+=head1 EXPORTS
+
+None
+
+=head1 ENVIRONMENT
+
+The environment variable C<PERL_RL> governs which ReadLine clone is
+loaded. If the value is false, a dummy interface is used. If the value
+is true, it should be tail of the name of the package to use, such as
+C<Perl> or C<Gnu>.
+
+As a special case, if the value of this variable is space-separated,
+the tail might be used to disable the ornaments by setting the tail to
+be C<o=0> or C<ornaments=0>. The head should be as described above, say
+
+If the variable is not set, or if the head of space-separated list is
+empty, the best available package is loaded.
+
+ export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
+ export "PERL_RL= o=0" # Use best available ReadLine without ornaments
+
+(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
+particular used C<Term::ReadLine::*> package).
+
+=head1 CAVEATS
+
+It seems that using Term::ReadLine from Emacs minibuffer doesn't work
+quite right and one will get an error message like
+
+ Cannot open /dev/tty for read at ...
+
+One possible workaround for this is to explicitly open /dev/tty like this
+
+ open (FH, "/dev/tty" )
+ or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
+ die $@ if $@;
+ close (FH);
+
+or you can try using the 4-argument form of Term::ReadLine->new().
+
+=cut
+
+use strict;
+
+package Term::ReadLine::Stub;
+our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+
+$DB::emacs = $DB::emacs; # To peacify -w
+our @rl_term_set;
+*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+
+sub PERL_UNICODE_STDIN () { 0x0001 }
+
+sub ReadLine {'Term::ReadLine::Stub'}
+sub readline {
+ my $self = shift;
+ my ($in,$out,$str) = @$self;
+ my $prompt = shift;
+ print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
+ $self->register_Tk
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+ and defined &Tk::DoOneEvent;
+ #$str = scalar <$in>;
+ $str = $self->get_line;
+ $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
+ utf8::upgrade($str)
+ if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
+ utf8::valid($str);
+ print $out $rl_term_set[3];
+ # bug in 5.000: chomping empty string creats length -1:
+ chomp $str if defined $str;
+ $str;
+}
+sub addhistory {}
+
+sub findConsole {
+ my $console;
+ my $consoleOUT;
+
+ if ($^O eq 'MacOS') {
+ $console = "Dev:Console";
+ } elsif (-e "/dev/tty") {
+ $console = "/dev/tty";
+ } elsif (-e "con" or $^O eq 'MSWin32') {
+ $console = 'CONIN$';
+ $consoleOUT = 'CONOUT$';
+ } else {
+ $console = "sys\$command";
+ }
+
+ if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
+ $console = undef;
+ }
+ elsif ($^O eq 'os2') {
+ if ($DB::emacs) {
+ $console = undef;
+ } else {
+ $console = "/dev/con";
+ }
+ }
+
+ $consoleOUT = $console unless defined $consoleOUT;
+ $console = "&STDIN" unless defined $console;
+ if (!defined $consoleOUT) {
+ $consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
+ }
+ ($console,$consoleOUT);
+}
+
+sub new {
+ die "method new called with wrong number of arguments"
+ unless @_==2 or @_==4;
+ #local (*FIN, *FOUT);
+ my ($FIN, $FOUT, $ret);
+ if (@_==2) {
+ my($console, $consoleOUT) = $_[0]->findConsole;
+
+
+ # the Windows CONIN$ needs GENERIC_WRITE mode to allow
+ # a SetConsoleMode() if we end up using Term::ReadKey
+ open FIN, ( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? "+<$console" :
+ "<$console";
+ open FOUT,">$consoleOUT";
+
+ #OUT->autoflush(1); # Conflicts with debugger?
+ my $sel = select(FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [\*FIN, \*FOUT];
+ } else { # Filehandles supplied
+ $FIN = $_[2]; $FOUT = $_[3];
+ #OUT->autoflush(1); # Conflicts with debugger?
+ my $sel = select($FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [$FIN, $FOUT];
+ }
+ if ($ret->Features->{ornaments}
+ and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $ret->ornaments(1);
+ }
+ return $ret;
+}
+
+sub newTTY {
+ my ($self, $in, $out) = @_;
+ $self->[0] = $in;
+ $self->[1] = $out;
+ my $sel = select($out);
+ $| = 1; # for DB::OUT
+ select($sel);
+}
+
+sub IN { shift->[0] }
+sub OUT { shift->[1] }
+sub MinLine { undef }
+sub Attribs { {} }
+
+my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
+sub Features { \%features }
+
+sub get_line {
+ my $self = shift;
+ my $in = $self->IN;
+ local ($/) = "\n";
+ return scalar <$in>;
+}
+
+package Term::ReadLine; # So late to allow the above code be defined?
+
+our $VERSION = '1.05';
+
+my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
+if ($which) {
+ if ($which =~ /\bgnu\b/i){
+ eval "use Term::ReadLine::Gnu;";
+ } elsif ($which =~ /\bperl\b/i) {
+ eval "use Term::ReadLine::Perl;";
+ } elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
+ # it is already in memory to avoid false exception as seen in:
+ # PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
+ } else {
+ eval "use Term::ReadLine::$which;";
+ }
+} elsif (defined $which and $which ne '') { # Defined but false
+ # Do nothing fancy
+} else {
+ eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
+}
+
+#require FileHandle;
+
+# To make possible switch off RL in debugger: (Not needed, work done
+# in debugger).
+our @ISA;
+if (defined &Term::ReadLine::Gnu::readline) {
+ @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
+} elsif (defined &Term::ReadLine::Perl::readline) {
+ @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
+} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
+ @ISA = "Term::ReadLine::$which";
+} else {
+ @ISA = qw(Term::ReadLine::Stub);
+}
+
+package Term::ReadLine::TermCap;
+
+# Prompt-start, prompt-end, command-line-start, command-line-end
+# -- zero-width beautifies to emit around prompt and the command line.
+our @rl_term_set = ("","","","");
+# string encoded:
+our $rl_term_set = ',,,';
+
+our $terminal;
+sub LoadTermCap {
+ return if defined $terminal;
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
+}
+
+sub ornaments {
+ shift;
+ return $rl_term_set unless @_;
+ $rl_term_set = shift;
+ $rl_term_set ||= ',,,';
+ $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
+ my @ts = split /,/, $rl_term_set, 4;
+ eval { LoadTermCap };
+ unless (defined $terminal) {
+ warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
+ $rl_term_set = ',,,';
+ return;
+ }
+ @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
+ return $rl_term_set;
+}
+
+
+package Term::ReadLine::Tk;
+
+our($count_handle, $count_DoOne, $count_loop);
+$count_handle = $count_DoOne = $count_loop = 0;
+
+our($giveup);
+sub handle {$giveup = 1; $count_handle++}
+
+sub Tk_loop {
+ # Tk->tkwait('variable',\$giveup); # needs Widget
+ $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
+ $count_loop++;
+ $giveup = 0;
+}
+
+sub register_Tk {
+ my $self = shift;
+ $Term::ReadLine::registered++
+ or Tk->fileevent($self->IN,'readable',\&handle);
+}
+
+sub tkRunning {
+ $Term::ReadLine::toloop = $_[1] if @_ > 1;
+ $Term::ReadLine::toloop;
+}
+
+sub get_c {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ return getc $self->IN;
+}
+
+sub get_line {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ my $in = $self->IN;
+ local ($/) = "\n";
+ return scalar <$in>;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Term/UI.pm b/Master/tlpkg/tlperl/lib/Term/UI.pm
new file mode 100644
index 00000000000..136f75bb6ad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/UI.pm
@@ -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@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@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
diff --git a/Master/tlpkg/tlperl/lib/Term/UI/History.pm b/Master/tlpkg/tlperl/lib/Term/UI/History.pm
new file mode 100644
index 00000000000..1d77c01c6f6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Term/UI/History.pm
@@ -0,0 +1,137 @@
+package Term::UI::History;
+
+use strict;
+use base 'Exporter';
+use base 'Log::Message::Simple';
+
+=pod
+
+=head1 NAME
+
+Term::UI::History
+
+=head1 SYNOPSIS
+
+ use Term::UI::History qw[history];
+
+ history("Some message");
+
+ ### retrieve the history in printable form
+ $hist = Term::UI::History->history_as_string;
+
+ ### redirect output
+ local $Term::UI::History::HISTORY_FH = \*STDERR;
+
+=head1 DESCRIPTION
+
+This module provides the C<history> function for C<Term::UI>,
+printing and saving all the C<UI> interaction.
+
+Refer to the C<Term::UI> manpage for details on usage from
+C<Term::UI>.
+
+This module subclasses C<Log::Message::Simple>. Refer to its
+manpage for additional functionality available via this package.
+
+=head1 FUNCTIONS
+
+=head2 history("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT>
+(or actually C<$HISTORY_FH>, see the C<GLOBAL VARIABLES> section
+below), if the C<VERBOSE> option is true.
+
+The C<VERBOSE> option defaults to true.
+
+=cut
+
+BEGIN {
+ use Log::Message private => 0;
+
+ use vars qw[ @EXPORT $HISTORY_FH ];
+ @EXPORT = qw[ history ];
+ my $log = new Log::Message;
+ $HISTORY_FH = \*STDOUT;
+
+ for my $func ( @EXPORT ) {
+ no strict 'refs';
+
+ *$func = sub { my $msg = shift;
+ $log->store(
+ message => $msg,
+ tag => uc $func,
+ level => $func,
+ extra => [@_]
+ );
+ };
+ }
+
+ sub history_as_string {
+ my $class = shift;
+
+ return join $/, map { $_->message } __PACKAGE__->stack;
+ }
+}
+
+
+{ package Log::Message::Handlers;
+
+ sub history {
+ my $self = shift;
+ my $verbose = shift;
+ $verbose = 1 unless defined $verbose; # default to true
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ local $| = 1;
+ my $old_fh = select $Term::UI::History::HISTORY_FH;
+
+ print $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+}
+
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $HISTORY_FH
+
+This is the filehandle all the messages sent to C<history()> are being
+printed. This defaults to C<*STDOUT>.
+
+=back
+
+=head1 See Also
+
+C<Log::Message::Simple>, C<Term::UI>
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2005 Jos Boumans E<lt>kane@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.
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder.pm b/Master/tlpkg/tlperl/lib/Test/Builder.pm
new file mode 100644
index 00000000000..26ffea41ff4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Builder.pm
@@ -0,0 +1,2501 @@
+package Test::Builder;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+BEGIN {
+ if( $] < 5.008 ) {
+ require Test::Builder::IO::Scalar;
+ }
+}
+
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+ # Load threads::shared when threads are turned on.
+ # 5.8.0's threads are so busted we no longer support them.
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ require threads::shared;
+
+ # Hack around YET ANOTHER threads::shared bug. It would
+ # occassionally forget the contents of the variable when sharing it.
+ # So we first copy the data, then share, then put our copy back.
+ *share = sub (\[$@%]) {
+ my $type = ref $_[0];
+ my $data;
+
+ if( $type eq 'HASH' ) {
+ %$data = %{ $_[0] };
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @$data = @{ $_[0] };
+ }
+ elsif( $type eq 'SCALAR' ) {
+ $$data = ${ $_[0] };
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ $_[0] = &threads::shared::share( $_[0] );
+
+ if( $type eq 'HASH' ) {
+ %{ $_[0] } = %$data;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @{ $_[0] } = @$data;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ ${ $_[0] } = $$data;
+ }
+ else {
+ die( "Unknown type: " . $type );
+ }
+
+ return $_[0];
+ };
+ }
+ # 5.8.0's threads::shared is busted when threads are off
+ # and earlier Perls just don't have that module at all.
+ else {
+ *share = sub { return $_[0] };
+ *lock = sub { 0 };
+ }
+}
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use base 'Test::Builder::Module';
+
+ my $CLASS = __PACKAGE__;
+
+ sub ok {
+ my($test, $name) = @_;
+ my $tb = $CLASS->builder;
+
+ $tb->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call C<new()>, you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=cut
+
+our $Test = Test::Builder->new;
+
+sub new {
+ my($class) = shift;
+ $Test ||= $class->create;
+ return $Test;
+}
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=cut
+
+sub create {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+ $self->reset;
+
+ return $self;
+}
+
+=item B<child>
+
+ my $child = $builder->child($name_of_child);
+ $child->plan( tests => 4 );
+ $child->ok(some_code());
+ ...
+ $child->finalize;
+
+Returns a new instance of C<Test::Builder>. Any output from this child will
+indented four spaces more than the parent's indentation. When done, the
+C<finalize> method I<must> be called explicitly.
+
+Trying to create a new child with a previous child still active (i.e.,
+C<finalize> not called) will C<croak>.
+
+Trying to run a test when you have an open child will also C<croak> and cause
+the test suite to fail.
+
+=cut
+
+sub child {
+ my( $self, $name ) = @_;
+
+ if( $self->{Child_Name} ) {
+ $self->croak("You already have a child named ($self->{Child_Name}) running");
+ }
+
+ my $child = bless {}, ref $self;
+ $child->reset;
+
+ # Add to our indentation
+ $child->_indent( $self->_indent . ' ' );
+ $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
+
+ # This will be reset in finalize. We do this here lest one child failure
+ # cause all children to fail.
+ $child->{Child_Error} = $?;
+ $? = 0;
+ $child->{Parent} = $self;
+ $child->{Name} = $name || "Child of " . $self->name;
+ $self->{Child_Name} = $child->name;
+ return $child;
+}
+
+
+=item B<subtest>
+
+ $builder->subtest($name, \&subtests);
+
+See documentation of C<subtest> in Test::More.
+
+=cut
+
+sub subtest {
+ my $self = shift;
+ my($name, $subtests) = @_;
+
+ if ('CODE' ne ref $subtests) {
+ $self->croak("subtest()'s second argument must be a code ref");
+ }
+
+ # Turn the child into the parent so anyone who has stored a copy of
+ # the Test::Builder singleton will get the child.
+ my $child = $self->child($name);
+ my %parent = %$self;
+ %$self = %$child;
+
+ my $error;
+ if( !eval { $subtests->(); 1 } ) {
+ $error = $@;
+ }
+
+ # Restore the parent and the copied child.
+ %$child = %$self;
+ %$self = %parent;
+
+ # Die *after* we restore the parent.
+ die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+
+ return $child->finalize;
+}
+
+
+=item B<finalize>
+
+ my $ok = $child->finalize;
+
+When your child is done running tests, you must call C<finalize> to clean up
+and tell the parent your pass/fail status.
+
+Calling finalize on a child with open children will C<croak>.
+
+If the child falls out of scope before C<finalize> is called, a failure
+diagnostic will be issued and the child is considered to have failed.
+
+No attempt to call methods on a child after C<finalize> is called is
+guaranteed to succeed.
+
+Calling this on the root builder is a no-op.
+
+=cut
+
+sub finalize {
+ my $self = shift;
+
+ return unless $self->parent;
+ if( $self->{Child_Name} ) {
+ $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
+ }
+ $self->_ending;
+
+ # XXX This will only be necessary for TAP envelopes (we think)
+ #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+
+ my $ok = 1;
+ $self->parent->{Child_Name} = undef;
+ if ( $self->{Skip_All} ) {
+ $self->parent->skip($self->{Skip_All});
+ }
+ elsif ( not @{ $self->{Test_Results} } ) {
+ $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
+ }
+ else {
+ $self->parent->ok( $self->is_passing, $self->name );
+ }
+ $? = $self->{Child_Error};
+ delete $self->{Parent};
+
+ return $self->is_passing;
+}
+
+sub _indent {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Indent} = shift;
+ }
+
+ return $self->{Indent};
+}
+
+=item B<parent>
+
+ if ( my $parent = $builder->parent ) {
+ ...
+ }
+
+Returns the parent C<Test::Builder> instance, if any. Only used with child
+builders for nested TAP.
+
+=cut
+
+sub parent { shift->{Parent} }
+
+=item B<name>
+
+ diag $builder->name;
+
+Returns the name of the current builder. Top level builders default to C<$0>
+(the name of the executable). Child builders are named via the C<child>
+method. If no name is supplied, will be named "Child of $parent->name".
+
+=cut
+
+sub name { shift->{Name} }
+
+sub DESTROY {
+ my $self = shift;
+ if ( $self->parent ) {
+ my $name = $self->name;
+ $self->diag(<<"FAIL");
+Child ($name) exited without calling finalize()
+FAIL
+ $self->parent->{In_Destroy} = 1;
+ $self->parent->ok(0, $name);
+ }
+}
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=cut
+
+our $Level;
+
+sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my($self) = @_;
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
+
+ $self->{Name} = $0;
+ $self->is_passing(1);
+ $self->{Ending} = 0;
+ $self->{Have_Plan} = 0;
+ $self->{No_Plan} = 0;
+ $self->{Have_Output_Plan} = 0;
+
+ $self->{Original_Pid} = $$;
+ $self->{Child_Name} = undef;
+ $self->{Indent} ||= '';
+
+ share( $self->{Curr_Test} );
+ $self->{Curr_Test} = 0;
+ $self->{Test_Results} = &share( [] );
+
+ $self->{Exported_To} = undef;
+ $self->{Expected_Tests} = 0;
+
+ $self->{Skip_All} = 0;
+
+ $self->{Use_Nums} = 1;
+
+ $self->{No_Header} = 0;
+ $self->{No_Ending} = 0;
+
+ $self->{Todo} = undef;
+ $self->{Todo_Stack} = [];
+ $self->{Start_Todo} = 0;
+ $self->{Opened_Testhandles} = 0;
+
+ $self->_dup_stdhandles;
+
+ return;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call C<plan()>, don't call any of the other methods below.
+
+If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
+thrown. Trap this error, call C<finalize()> and don't run any more tests on
+the child.
+
+ my $child = $Test->child('some child');
+ eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
+ if ( eval { $@->isa('Test::Builder::Exception') } ) {
+ $child->finalize;
+ return;
+ }
+ # run your tests
+
+=cut
+
+my %plan_cmds = (
+ no_plan => \&no_plan,
+ skip_all => \&skip_all,
+ tests => \&_plan_tests,
+);
+
+sub plan {
+ my( $self, $cmd, $arg ) = @_;
+
+ return unless $cmd;
+
+ local $Level = $Level + 1;
+
+ $self->croak("You tried to plan twice") if $self->{Have_Plan};
+
+ if( my $method = $plan_cmds{$cmd} ) {
+ local $Level = $Level + 1;
+ $self->$method($arg);
+ }
+ else {
+ my @args = grep { defined } ( $cmd, $arg );
+ $self->croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+
+sub _plan_tests {
+ my($self, $arg) = @_;
+
+ if($arg) {
+ local $Level = $Level + 1;
+ return $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ $self->croak("Got an undefined number of tests");
+ }
+ else {
+ $self->croak("You said to run 0 tests");
+ }
+
+ return;
+}
+
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the number of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+sub expected_tests {
+ my $self = shift;
+ my($max) = @_;
+
+ if(@_) {
+ $self->croak("Number of tests must be a positive integer. You gave it '$max'")
+ unless $max =~ /^\+?\d+$/;
+
+ $self->{Expected_Tests} = $max;
+ $self->{Have_Plan} = 1;
+
+ $self->_output_plan($max) unless $self->no_header;
+ }
+ return $self->{Expected_Tests};
+}
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate number of tests.
+
+=cut
+
+sub no_plan {
+ my($self, $arg) = @_;
+
+ $self->carp("no_plan takes no arguments") if $arg;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
+
+ return 1;
+}
+
+
+=begin private
+
+=item B<_output_plan>
+
+ $tb->_output_plan($max);
+ $tb->_output_plan($max, $directive);
+ $tb->_output_plan($max, $directive => $reason);
+
+Handles displaying the test plan.
+
+If a C<$directive> and/or C<$reason> are given they will be output with the
+plan. So here's what skipping all tests looks like:
+
+ $tb->_output_plan(0, "SKIP", "Because I said so");
+
+It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
+output.
+
+=end private
+
+=cut
+
+sub _output_plan {
+ my($self, $max, $directive, $reason) = @_;
+
+ $self->carp("The plan was already output") if $self->{Have_Output_Plan};
+
+ my $plan = "1..$max";
+ $plan .= " # $directive" if defined $directive;
+ $plan .= " $reason" if defined $reason;
+
+ $self->_print("$plan\n");
+
+ $self->{Have_Output_Plan} = 1;
+
+ return;
+}
+
+=item B<done_testing>
+
+ $Test->done_testing();
+ $Test->done_testing($num_tests);
+
+Declares that you are done testing, no more tests will be run after this point.
+
+If a plan has not yet been output, it will do so.
+
+$num_tests is the number of tests you planned to run. If a numbered
+plan was already declared, and if this contradicts, a failing test
+will be run to reflect the planning mistake. If C<no_plan> was declared,
+this will override.
+
+If C<done_testing()> is called twice, the second call will issue a
+failing test.
+
+If C<$num_tests> is omitted, the number of tests run will be used, like
+no_plan.
+
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
+safer. You'd use it like so:
+
+ $Test->ok($a == $b);
+ $Test->done_testing();
+
+Or to plan a variable number of tests:
+
+ for my $test (@tests) {
+ $Test->ok($test);
+ }
+ $Test->done_testing(@tests);
+
+=cut
+
+sub done_testing {
+ my($self, $num_tests) = @_;
+
+ # If done_testing() specified the number of tests, shut off no_plan.
+ if( defined $num_tests ) {
+ $self->{No_Plan} = 0;
+ }
+ else {
+ $num_tests = $self->current_test;
+ }
+
+ if( $self->{Done_Testing} ) {
+ my($file, $line) = @{$self->{Done_Testing}}[1,2];
+ $self->ok(0, "done_testing() was already called at $file line $line");
+ return;
+ }
+
+ $self->{Done_Testing} = [caller];
+
+ if( $self->expected_tests && $num_tests != $self->expected_tests ) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
+ "but done_testing() expects $num_tests");
+ }
+ else {
+ $self->{Expected_Tests} = $num_tests;
+ }
+
+ $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
+
+ $self->{Have_Plan} = 1;
+
+ # The wrong number of tests were run
+ $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
+
+ # No tests were run
+ $self->is_passing(0) if $self->{Curr_Test} == 0;
+
+ return 1;
+}
+
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
+of expected tests).
+
+=cut
+
+sub has_plan {
+ my $self = shift;
+
+ return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
+ return('no_plan') if $self->{No_Plan};
+ return(undef);
+}
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
+
+=cut
+
+sub skip_all {
+ my( $self, $reason ) = @_;
+
+ $self->{Skip_All} = $self->parent ? $reason : 1;
+
+ $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
+ if ( $self->parent ) {
+ die bless {} => 'Test::Builder::Exception';
+ }
+ exit(0);
+}
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
+
+=cut
+
+sub exported_to {
+ my( $self, $pack ) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
+
+C<$name> is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
+like Test::Simple's C<ok()>.
+
+=cut
+
+sub ok {
+ my( $self, $test, $name ) = @_;
+
+ if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
+ $name = 'unnamed test' unless defined $name;
+ $self->is_passing(0);
+ $self->croak("Cannot run test ($name) with active children");
+ }
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ lock $self->{Curr_Test};
+ $self->{Curr_Test}++;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ $self->_unoverload_str( \$name );
+
+ $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ # Capture the value of $TODO for the rest of this ok() call
+ # so it can more easily be found by other routines.
+ my $todo = $self->todo();
+ my $in_todo = $self->in_todo;
+ local $self->{Todo} = $todo if $in_todo;
+
+ $self->_unoverload_str( \$todo );
+
+ my $out;
+ my $result = &share( {} );
+
+ unless($test) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $self->in_todo ) {
+ $out .= " # TODO $todo";
+ $result->{reason} = $todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless($test) {
+ my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
+ $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
+
+ my( undef, $file, $line ) = $self->caller;
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
+ }
+
+ $self->is_passing(0) unless $test || $self->in_todo;
+
+ # Check that we haven't violated the plan
+ $self->_check_is_passing_plan();
+
+ return $test ? 1 : 0;
+}
+
+
+# Check that we haven't yet violated the plan and set
+# is_passing() accordingly
+sub _check_is_passing_plan {
+ my $self = shift;
+
+ my $plan = $self->has_plan;
+ return unless defined $plan; # no plan yet defined
+ return unless $plan !~ /\D/; # no numeric plan
+ $self->is_passing(0) if $plan < $self->{Curr_Test};
+}
+
+
+sub _unoverload {
+ my $self = shift;
+ my $type = shift;
+
+ $self->_try(sub { require overload; }, die_on_fail => 1);
+
+ foreach my $thing (@_) {
+ if( $self->_is_object($$thing) ) {
+ if( my $string_meth = overload::Method( $$thing, $type ) ) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ }
+
+ return;
+}
+
+sub _is_object {
+ my( $self, $thing ) = @_;
+
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
+}
+
+sub _unoverload_str {
+ my $self = shift;
+
+ return $self->_unoverload( q[""], @_ );
+}
+
+sub _unoverload_num {
+ my $self = shift;
+
+ $self->_unoverload( '0+', @_ );
+
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
+ }
+
+ return;
+}
+
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my( $self, $val ) = @_;
+
+ # Objects are not dualvars.
+ return 0 if ref $val;
+
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return $numval != 0 and $numval ne $val ? 1 : 0;
+}
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_str( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'eq', $expect, $name );
+}
+
+sub is_num {
+ my( $self, $got, $expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ $self->_unoverload_num( \$got, \$expect );
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, '==', $expect ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '==', $expect, $name );
+}
+
+sub _diag_fmt {
+ my( $self, $type, $val ) = @_;
+
+ if( defined $$val ) {
+ if( $type eq 'eq' or $type eq 'ne' ) {
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+ # force numeric context
+ $self->_unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+
+ return;
+}
+
+sub _is_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: $expect
+DIAGNOSTIC
+
+}
+
+sub _isnt_diag {
+ my( $self, $got, $type ) = @_;
+
+ $self->_diag_fmt( $type, \$got );
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: anything else
+DIAGNOSTIC
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->isnt_num($got, $dont_expect, $name);
+
+Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, 'ne' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+}
+
+sub isnt_num {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, '!=' ) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+}
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's C<unlike()>. Checks if $this B<does not match> the
+given C<$regex>.
+
+=cut
+
+sub like {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '=~', $name );
+}
+
+sub unlike {
+ my( $self, $this, $regex, $name ) = @_;
+
+ local $Level = $Level + 1;
+ return $self->_regex_ok( $this, $regex, '!~', $name );
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's C<cmp_ok()>.
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+sub cmp_ok {
+ my( $self, $got, $type, $expect, $name ) = @_;
+
+ my $test;
+ my $error;
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ my($pack, $file, $line) = $self->caller();
+
+ $test = eval qq[
+#line 1 "cmp_ok [from $file line $line]"
+\$got $type \$expect;
+];
+ $error = $@;
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok( $test, $name );
+
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload
+ = $numeric_cmps{$type}
+ ? '_unoverload_num'
+ : '_unoverload_str';
+
+ $self->diag(<<"END") if $error;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+END
+
+ unless($ok) {
+ $self->$unoverload( \$got, \$expect );
+
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag( $got, $type, $expect );
+ }
+ elsif( $type =~ /^(ne|!=)$/ ) {
+ $self->_isnt_diag( $got, $type );
+ }
+ else {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ $got
+ $type
+ $expect
+DIAGNOSTIC
+}
+
+sub _caller_context {
+ my $self = shift;
+
+ my( $pack, $file, $line ) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ $Test->BAIL_OUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
+
+ $self->{Bailed_Out} = 1;
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
+
+=cut
+
+{
+ no warnings 'once';
+ *BAILOUT = \&BAIL_OUT;
+}
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting C<$why>.
+
+=cut
+
+sub skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+ $self->_unoverload_str( \$why );
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+
+ lock( $self->{Curr_Test} );
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ }
+ );
+
+ my $out = "not ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like C<skip()>, only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under C<no_plan>, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+This method used to be useful back when Test::Builder worked on Perls
+before 5.6 which didn't have qr//. Now its pretty useless.
+
+Convenience method for building testing functions that take regular
+expressions as arguments.
+
+Takes a quoted regular expression produced by C<qr//>, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or C<undef> if its argument is not recognised.
+
+For example, a version of C<like()>, sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+sub maybe_regex {
+ my( $self, $regex ) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my( $re, $opts );
+
+ # Check for qr/foo/
+ if( _is_qr($regex) ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+sub _is_qr {
+ my $regex = shift;
+
+ # is_regexp() checks for regexes in a robust manner, say if they're
+ # blessed.
+ return re::is_regexp($regex) if defined &re::is_regexp;
+ return ref $regex eq 'Regexp';
+}
+
+sub _regex_ok {
+ my( $self, $this, $regex, $cmp, $name ) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless( defined $usable_regex ) {
+ local $Level = $Level + 1;
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ my $test;
+ my $context = $self->_caller_context;
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless($ok) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+
+ local $Level = $Level + 1;
+ $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+# I'm not ready to publish this. It doesn't deal with array return
+# values from the code or context.
+
+=begin private
+
+=item B<_try>
+
+ my $return_from_code = $Test->try(sub { code });
+ my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest
+of the test (ie. C<$@> is not set) nor is effected by outside
+interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
+Perls.
+
+C<$error> is what would normally be in C<$@>.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
+ }
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+ my $is_fh = $Test->is_fh($thing);
+
+Determines if the given C<$thing> can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ eval { tied($maybe_fh)->can('TIEHANDLE') };
+}
+
+=back
+
+
+=head2 Test style
+
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should C<$Test> look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting L<$Test::Builder::Level> overrides. This is typically useful
+localized:
+
+ sub my_ok {
+ my $test = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
+ }
+
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
+=cut
+
+sub level {
+ my( $self, $level ) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Defaults to on.
+
+=cut
+
+sub use_numbers {
+ my( $self, $use_nums ) = @_;
+
+ if( defined $use_nums ) {
+ $self->{Use_Nums} = $use_nums;
+ }
+ return $self->{Use_Nums};
+}
+
+=item B<no_diag>
+
+ $Test->no_diag($no_diag);
+
+If set true no diagnostics will be printed. This includes calls to
+C<diag()>.
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
+
+If this is true, none of that will be done.
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=cut
+
+foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
+ my $method = lc $attribute;
+
+ my $code = sub {
+ my( $self, $no ) = @_;
+
+ if( defined $no ) {
+ $self->{$attribute} = $no;
+ }
+ return $self->{$attribute};
+ };
+
+ no strict 'refs'; ## no critic
+ *{ __PACKAGE__ . '::' . $method } = $code;
+}
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given C<@msgs>. Like C<print>, arguments are simply
+appended together.
+
+Normally, it uses the C<failure_output()> handle, but if this is for a
+TODO test, the C<todo_output()> handle is used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because C<diag()> is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my $self = shift;
+
+ $self->_print_comment( $self->_diag_fh, @_ );
+}
+
+=item B<note>
+
+ $Test->note(@msgs);
+
+Like C<diag()>, but it prints to the C<output()> handle so it will not
+normally be seen by the user except in verbose mode.
+
+=cut
+
+sub note {
+ my $self = shift;
+
+ $self->_print_comment( $self->output, @_ );
+}
+
+sub _diag_fh {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
+}
+
+sub _print_comment {
+ my( $self, $fh, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape the beginning, _print will take care of the rest.
+ $msg =~ s/^/# /;
+
+ local $Level = $Level + 1;
+ $self->_print_to_fh( $fh, $msg );
+
+ return 0;
+}
+
+=item B<explain>
+
+ my @dump = $Test->explain(@msgs);
+
+Will dump the contents of any references in a human readable format.
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ is_deeply($have, $want) || note explain $have;
+
+=cut
+
+sub explain {
+ my $self = shift;
+
+ return map {
+ ref $_
+ ? do {
+ $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
+
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the C<output()> filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my $self = shift;
+ return $self->_print_to_fh( $self->output, @_ );
+}
+
+sub _print_to_fh {
+ my( $self, $fh, @msgs ) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ my $msg = join '', @msgs;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ $msg =~ s{\n(?!\z)}{\n# }sg;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\z/;
+
+ return print $fh $self->_indent, $msg;
+}
+
+=item B<output>
+
+=item B<failure_output>
+
+=item B<todo_output>
+
+ my $filehandle = $Test->output;
+ $Test->output($filehandle);
+ $Test->output($filename);
+ $Test->output(\$scalar);
+
+These methods control where Test::Builder will print its output.
+They take either an open C<$filehandle>, a C<$filename> to open and write to
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
+
+B<output> is where normal "ok/not ok" test output goes.
+
+Defaults to STDOUT.
+
+B<failure_output> is where diagnostic output on test failures and
+C<diag()> goes. It is normally not read by Test::Harness and instead is
+displayed to the user.
+
+Defaults to STDERR.
+
+C<todo_output> is used instead of C<failure_output()> for the
+diagnostics of a failing TODO test. These will not be seen by the
+user.
+
+Defaults to STDOUT.
+
+=cut
+
+sub output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Out_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Out_FH};
+}
+
+sub failure_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Fail_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Fail_FH};
+}
+
+sub todo_output {
+ my( $self, $fh ) = @_;
+
+ if( defined $fh ) {
+ $self->{Todo_FH} = $self->_new_fh($fh);
+ }
+ return $self->{Todo_FH};
+}
+
+sub _new_fh {
+ my $self = shift;
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
+ # Scalar refs as filehandles was added in 5.8.
+ if( $] >= 5.008 ) {
+ open $fh, ">>", $file_or_fh
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
+ }
+ # Emulate scalar ref filehandles with a tie.
+ else {
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
+ or $self->croak("Can't tie scalar ref $file_or_fh");
+ }
+ }
+ else {
+ open $fh, ">", $file_or_fh
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+my( $Testout, $Testerr );
+
+sub _dup_stdhandles {
+ my $self = shift;
+
+ $self->_open_testhandles;
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush($Testout);
+ _autoflush( \*STDOUT );
+ _autoflush($Testerr);
+ _autoflush( \*STDERR );
+
+ $self->reset_outputs;
+
+ return;
+}
+
+sub _open_testhandles {
+ my $self = shift;
+
+ return if $self->{Opened_Testhandles};
+
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
+ open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
+
+ # $self->_copy_io_layers( \*STDOUT, $Testout );
+ # $self->_copy_io_layers( \*STDERR, $Testerr );
+
+ $self->{Opened_Testhandles} = 1;
+
+ return;
+}
+
+sub _copy_io_layers {
+ my( $self, $src, $dst ) = @_;
+
+ $self->_try(
+ sub {
+ require PerlIO;
+ my @src_layers = PerlIO::get_layers($src);
+
+ binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ }
+ );
+
+ return;
+}
+
+=item reset_outputs
+
+ $tb->reset_outputs;
+
+Resets all the output filehandles back to their defaults.
+
+=cut
+
+sub reset_outputs {
+ my $self = shift;
+
+ $self->output ($Testout);
+ $self->failure_output($Testerr);
+ $self->todo_output ($Testout);
+
+ return;
+}
+
+=item carp
+
+ $tb->carp(@message);
+
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=item croak
+
+ $tb->croak(@message);
+
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
+
+=cut
+
+sub _message_at_caller {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my( $pack, $file, $line ) = $self->caller;
+ return join( "", @_ ) . " at $file line $line.\n";
+}
+
+sub carp {
+ my $self = shift;
+ return warn $self->_message_at_caller(@_);
+}
+
+sub croak {
+ my $self = shift;
+ return die $self->_message_at_caller(@_);
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
+
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
+
+=cut
+
+sub current_test {
+ my( $self, $num ) = @_;
+
+ lock( $self->{Curr_Test} );
+ if( defined $num ) {
+ $self->{Curr_Test} = $num;
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $self->{Test_Results};
+ if( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for( $start .. $num - 1 ) {
+ $test_results->[$_] = &share(
+ {
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ }
+ );
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return $self->{Curr_Test};
+}
+
+=item B<is_passing>
+
+ my $ok = $builder->is_passing;
+
+Indicates if the test suite is currently passing.
+
+More formally, it will be false if anything has happened which makes
+it impossible for the test suite to pass. True otherwise.
+
+For example, if no tests have run C<is_passing()> will be true because
+even though a suite with no tests is a failure you can add a passing
+test to it and start passing.
+
+Don't think about it too much.
+
+=cut
+
+sub is_passing {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Is_Passing} = shift;
+ }
+
+ return $self->{Is_Passing};
+}
+
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my($self) = shift;
+
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like C<summary()>, but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when C<current_test()> is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+its type is 'unknown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left C<undef>.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since its todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ my $self = shift;
+ return @{ $self->{Test_Results} };
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+If the current tests are considered "TODO" it will return the reason,
+if any. This reason can come from a C<$TODO> variable or the last call
+to C<todo_start()>.
+
+Since a TODO test does not need a reason, this function can return an
+empty string even when inside a TODO block. Use C<< $Test->in_todo >>
+to determine if you are currently inside a TODO block.
+
+C<todo()> is about finding the right package to look for C<$TODO> in. It's
+pretty good at guessing the right package to look at. It first looks for
+the caller based on C<$Level + 1>, since C<todo()> is usually called inside
+a test function. As a last resort it will use C<exported_to()>.
+
+Sometimes there is some confusion about where todo() should be looking
+for the C<$TODO> variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my( $self, $pack ) = @_;
+
+ return $self->{Todo} if defined $self->{Todo};
+
+ local $Level = $Level + 1;
+ my $todo = $self->find_TODO($pack);
+ return $todo if defined $todo;
+
+ return '';
+}
+
+=item B<find_TODO>
+
+ my $todo_reason = $Test->find_TODO();
+ my $todo_reason = $Test->find_TODO($pack):
+
+Like C<todo()> but only returns the value of C<$TODO> ignoring
+C<todo_start()>.
+
+=cut
+
+sub find_TODO {
+ my( $self, $pack ) = @_;
+
+ $pack = $pack || $self->caller(1) || $self->exported_to;
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ return ${ $pack . '::TODO' };
+}
+
+=item B<in_todo>
+
+ my $in_todo = $Test->in_todo;
+
+Returns true if the test is currently inside a TODO block.
+
+=cut
+
+sub in_todo {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
+}
+
+=item B<todo_start>
+
+ $Test->todo_start();
+ $Test->todo_start($message);
+
+This method allows you declare all subsequent tests as TODO tests, up until
+the C<todo_end> method has been called.
+
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
+whether or not we're in a TODO test. However, often we find that this is not
+possible to determine (such as when we want to use C<$TODO> but
+the tests are being executed in other packages which can't be inferred
+beforehand).
+
+Note that you can use this to nest "todo" tests
+
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+
+This is generally not recommended, but large testing systems often have weird
+internal needs.
+
+We've tried to make this also work with the TODO: syntax, but it's not
+guaranteed and its use is also discouraged:
+
+ TODO: {
+ local $TODO = 'We have work to do!';
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+ }
+
+Pick one style or another of "TODO" to be on the safe side.
+
+=cut
+
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
+
+ $self->{Start_Todo}++;
+ if( $self->in_todo ) {
+ push @{ $self->{Todo_Stack} } => $self->todo;
+ }
+ $self->{Todo} = $message;
+
+ return;
+}
+
+=item C<todo_end>
+
+ $Test->todo_end;
+
+Stops running tests as "TODO" tests. This method is fatal if called without a
+preceding C<todo_start> method call.
+
+=cut
+
+sub todo_end {
+ my $self = shift;
+
+ if( !$self->{Start_Todo} ) {
+ $self->croak('todo_end() called without todo_start()');
+ }
+
+ $self->{Start_Todo}--;
+
+ if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
+ $self->{Todo} = pop @{ $self->{Todo_Stack} };
+ }
+ else {
+ delete $self->{Todo};
+ }
+
+ return;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal C<caller()>, except it reports according to your C<level()>.
+
+C<$height> will be added to the C<level()>.
+
+If C<caller()> winds up off the top of the stack it report the highest context.
+
+=cut
+
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my( $self, $height ) = @_;
+ $height ||= 0;
+
+ my $level = $self->level + $height + 1;
+ my @caller;
+ do {
+ @caller = CORE::caller( $level );
+ $level--;
+ } until @caller;
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ $self->_sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ my $self = shift;
+
+ $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
+ $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
+ 'Somehow you got a different number of results than tests ran!' );
+
+ return;
+}
+
+=item B<_whoa>
+
+ $self->_whoa($check, $description);
+
+A sanity check, similar to C<assert()>. If the C<$check> is true, something
+has gone horribly wrong. It will die with the given C<$description> and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my( $self, $check, $desc ) = @_;
+ if($check) {
+ local $Level = $Level + 1;
+ $self->croak(<<"WHOA");
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+
+ return;
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an C<END> block.
+5.6.1 does some odd things. Instead, this function edits C<$?>
+directly. It should B<only> be called from inside an C<END> block.
+It doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
+
+ return 1;
+}
+
+=back
+
+=end _private
+
+=cut
+
+sub _ending {
+ my $self = shift;
+ return if $self->no_ending;
+ return if $self->{Ending}++;
+
+ my $real_exit_code = $?;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ if( $self->{Original_Pid} != $$ ) {
+ return;
+ }
+
+ # Ran tests but never declared a plan or hit done_testing
+ if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
+ $self->is_passing(0);
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+ }
+
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ if( !$self->{Have_Plan} ) {
+ return;
+ }
+
+ # Don't do an ending if we bailed out.
+ if( $self->{Bailed_Out} ) {
+ $self->is_passing(0);
+ return;
+ }
+ # Figure out if we passed or failed and print helpful messages.
+ my $test_results = $self->{Test_Results};
+ if(@$test_results) {
+ # The plan? We have no plan.
+ if( $self->{No_Plan} ) {
+ $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
+ $self->{Expected_Tests} = $self->{Curr_Test};
+ }
+
+ # Auto-extended arrays and elements which aren't explicitly
+ # filled in with a shared reference will puke under 5.8.0
+ # ithreads. So we have to fill them in by hand. :(
+ my $empty_result = &share( {} );
+ for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
+ $test_results->[$idx] = $empty_result
+ unless defined $test_results->[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+
+ my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+
+ if( $num_extra != 0 ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ }
+
+ if($num_failed) {
+ my $num_tests = $self->{Curr_Test};
+ my $s = $num_failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed test$s of $num_tests$qualifier.
+FAIL
+ $self->is_passing(0);
+ }
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+
+ my $exit_code;
+ if($num_failed) {
+ $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ }
+ elsif( $num_extra != 0 ) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ _my_exit($exit_code) && return;
+ }
+ elsif( $self->{Skip_All} ) {
+ _my_exit(0) && return;
+ }
+ elsif($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code before it could output anything.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+ else {
+ $self->diag("No tests run!\n");
+ $self->is_passing(0);
+ _my_exit(255) && return;
+ }
+
+ $self->is_passing(0);
+ $self->_whoa( 1, "We fell off the end of _ending()" );
+}
+
+END {
+ $Test->_ending if defined $Test;
+}
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+=head1 THREADS
+
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using C<current_test()> they will all be effected.
+
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
+
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
+
+=head1 MEMORY
+
+An informative hash, accessable via C<<details()>>, is stored for each
+test you perform. So memory usage will scale linearly with each test
+run. Although this is not a problem for most test suites, it can
+become an issue if you do large (hundred thousands to million)
+combinatorics tests in the same run.
+
+In such cases, you are advised to either split the test file into smaller
+ones, or use a reverse approach, doing "normal" (code) compares and
+triggering fail() should anything go unexpected.
+
+Future versions of Test::Builder will have a way to turn history off.
+
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm
new file mode 100644
index 00000000000..4f7d1aa7db7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm
@@ -0,0 +1,173 @@
+package Test::Builder::Module;
+
+use strict;
+
+use Test::Builder;
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+
+=head1 NAME
+
+Test::Builder::Module - Base class for test modules
+
+=head1 SYNOPSIS
+
+ # Emulates Test::Simple
+ package Your::Module;
+
+ my $CLASS = __PACKAGE__;
+
+ use base 'Test::Builder::Module';
+ @EXPORT = qw(ok);
+
+ sub ok ($;$) {
+ my $tb = $CLASS->builder;
+ return $tb->ok(@_);
+ }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This is a superclass for Test::Builder-based modules. It provides a
+handful of common functionality and a method of getting at the underlying
+Test::Builder object.
+
+
+=head2 Importing
+
+Test::Builder::Module is a subclass of Exporter which means your
+module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
+all act normally.
+
+A few methods are provided to do the C<use Your::Module tests => 23> part
+for you.
+
+=head3 import
+
+Test::Builder::Module provides an import() method which acts in the
+same basic way as Test::More's, setting the plan and controling
+exporting of functions and variables. This allows your module to set
+the plan independent of Test::More.
+
+All arguments passed to import() are passed onto
+C<< Your::Module->builder->plan() >> with the exception of
+C<import =>[qw(things to import)]>.
+
+ use Your::Module import => [qw(this that)], tests => 23;
+
+says to import the functions this() and that() as well as set the plan
+to be 23 tests.
+
+import() also sets the exported_to() attribute of your builder to be
+the caller of the import() function.
+
+Additional behaviors can be added to your import() method by overriding
+import_extra().
+
+=cut
+
+sub import {
+ my($class) = shift;
+
+ # Don't run all this when loading ourself.
+ return 1 if $class eq 'Test::Builder::Module';
+
+ my $test = $class->builder;
+
+ my $caller = caller;
+
+ $test->exported_to($caller);
+
+ $class->import_extra( \@_ );
+ my(@imports) = $class->_strip_imports( \@_ );
+
+ $test->plan(@_);
+
+ $class->export_to_level( 1, $class, @imports );
+}
+
+sub _strip_imports {
+ my $class = shift;
+ my $list = shift;
+
+ my @imports = ();
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'import' ) {
+ push @imports, @{ $list->[ $idx + 1 ] };
+ $idx++;
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return @imports;
+}
+
+=head3 import_extra
+
+ Your::Module->import_extra(\@import_args);
+
+import_extra() is called by import(). It provides an opportunity for you
+to add behaviors to your module based on its import list.
+
+Any extra arguments which shouldn't be passed on to plan() should be
+stripped off by this method.
+
+See Test::More for an example of its use.
+
+B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
+feels like a bit of an ugly hack in its current form.
+
+=cut
+
+sub import_extra { }
+
+=head2 Builder
+
+Test::Builder::Module provides some methods of getting at the underlying
+Test::Builder object.
+
+=head3 builder
+
+ my $builder = Your::Class->builder;
+
+This method returns the Test::Builder object associated with Your::Class.
+It is not a constructor so you can call it as often as you like.
+
+This is the preferred way to get the Test::Builder object. You should
+I<not> get it via C<< Test::Builder->new >> as was previously
+recommended.
+
+The object returned by builder() may change at runtime so you should
+call builder() inside each function rather than store it in a global.
+
+ sub ok {
+ my $builder = Your::Class->builder;
+
+ return $builder->ok(@_);
+ }
+
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm
new file mode 100644
index 00000000000..7bea6f99da6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm
@@ -0,0 +1,603 @@
+package Test::Builder::Tester;
+
+use strict;
+our $VERSION = "1.18";
+
+use Test::Builder;
+use Symbol;
+use Carp;
+
+=head1 NAME
+
+Test::Builder::Tester - test testsuites that have been built with
+Test::Builder
+
+=head1 SYNOPSIS
+
+ use Test::Builder::Tester tests => 1;
+ use Test::More;
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=head1 DESCRIPTION
+
+A module that helps you test testing modules that are built with
+B<Test::Builder>.
+
+The testing system is designed to be used by performing a three step
+process for each test you wish to test. This process starts with using
+C<test_out> and C<test_err> in advance to declare what the testsuite you
+are testing will output with B<Test::Builder> to stdout and stderr.
+
+You then can run the test(s) from your test suite that call
+B<Test::Builder>. At this point the output of B<Test::Builder> is
+safely captured by B<Test::Builder::Tester> rather than being
+interpreted as real test output.
+
+The final stage is to call C<test_test> that will simply compare what you
+predeclared to what B<Test::Builder> actually outputted, and report the
+results back with a "ok" or "not ok" (with debugging) to the normal
+output.
+
+=cut
+
+####
+# set up testing
+####
+
+my $t = Test::Builder->new;
+
+###
+# make us an exporter
+###
+
+use Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+
+sub import {
+ my $class = shift;
+ my(@plan) = @_;
+
+ my $caller = caller;
+
+ $t->exported_to($caller);
+ $t->plan(@plan);
+
+ my @imports = ();
+ foreach my $idx ( 0 .. $#plan ) {
+ if( $plan[$idx] eq 'import' ) {
+ @imports = @{ $plan[ $idx + 1 ] };
+ last;
+ }
+ }
+
+ __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
+}
+
+###
+# set up file handles
+###
+
+# create some private file handles
+my $output_handle = gensym;
+my $error_handle = gensym;
+
+# and tie them to this package
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
+
+####
+# exported functions
+####
+
+# for remembering that we're testing and where we're testing at
+my $testing = 0;
+my $testing_num;
+
+# remembering where the file handles were originally connected
+my $original_output_handle;
+my $original_failure_handle;
+my $original_todo_handle;
+
+my $original_test_number;
+my $original_harness_state;
+
+my $original_harness_env;
+
+# function that starts testing and redirects the filehandles for now
+sub _start_testing {
+ # even if we're running under Test::Harness pretend we're not
+ # for now. This needed so Test::Builder doesn't add extra spaces
+ $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
+ $ENV{HARNESS_ACTIVE} = 0;
+
+ # remember what the handles were set to
+ $original_output_handle = $t->output();
+ $original_failure_handle = $t->failure_output();
+ $original_todo_handle = $t->todo_output();
+
+ # switch out to our own handles
+ $t->output($output_handle);
+ $t->failure_output($error_handle);
+ $t->todo_output($error_handle);
+
+ # clear the expected list
+ $out->reset();
+ $err->reset();
+
+ # remeber that we're testing
+ $testing = 1;
+ $testing_num = $t->current_test;
+ $t->current_test(0);
+
+ # look, we shouldn't do the ending stuff
+ $t->no_ending(1);
+}
+
+=head2 Functions
+
+These are the six methods that are exported as default.
+
+=over 4
+
+=item test_out
+
+=item test_err
+
+Procedures for predeclaring the output that your test suite is
+expected to produce until C<test_test> is called. These procedures
+automatically assume that each line terminates with "\n". So
+
+ test_out("ok 1","ok 2");
+
+is the same as
+
+ test_out("ok 1\nok 2");
+
+which is even the same as
+
+ test_out("ok 1");
+ test_out("ok 2");
+
+Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
+been called once all further output from B<Test::Builder> will be
+captured by B<Test::Builder::Tester>. This means that your will not
+be able perform further tests to the normal output in the normal way
+until you call C<test_test> (well, unless you manually meddle with the
+output filehandles)
+
+=cut
+
+sub test_out {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $out->expect(@_);
+}
+
+sub test_err {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ $err->expect(@_);
+}
+
+=item test_fail
+
+Because the standard failure message that B<Test::Builder> produces
+whenever a test fails will be a common occurrence in your test error
+output, and because has changed between Test::Builder versions, rather
+than forcing you to call C<test_err> with the string all the time like
+so
+
+ test_err("# Failed test ($0 at line ".line_num(+1).")");
+
+C<test_fail> exists as a convenience function that can be called
+instead. It takes one argument, the offset from the current line that
+the line that causes the fail is on.
+
+ test_fail(+1);
+
+This means that the example in the synopsis could be rewritten
+more simply as:
+
+ test_out("not ok 1 - foo");
+ test_fail(+1);
+ fail("foo");
+ test_test("fail works");
+
+=cut
+
+sub test_fail {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # work out what line we should be on
+ my( $package, $filename, $line ) = caller;
+ $line = $line + ( shift() || 0 ); # prevent warnings
+
+ # expect that on stderr
+ $err->expect("# Failed test ($0 at line $line)");
+}
+
+=item test_diag
+
+As most of the remaining expected output to the error stream will be
+created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
+provides a convience function C<test_diag> that you can use instead of
+C<test_err>.
+
+The C<test_diag> function prepends comment hashes and spacing to the
+start and newlines to the end of the expected output passed to it and
+adds it to the list of expected error output. So, instead of writing
+
+ test_err("# Couldn't open file");
+
+you can write
+
+ test_diag("Couldn't open file");
+
+Remember that B<Test::Builder>'s diag function will not add newlines to
+the end of output and test_diag will. So to check
+
+ Test::Builder->new->diag("foo\n","bar\n");
+
+You would do
+
+ test_diag("foo","bar")
+
+without the newlines.
+
+=cut
+
+sub test_diag {
+ # do we need to do any setup?
+ _start_testing() unless $testing;
+
+ # expect the same thing, but prepended with "# "
+ local $_;
+ $err->expect( map { "# $_" } @_ );
+}
+
+=item test_test
+
+Actually performs the output check testing the tests, comparing the
+data (with C<eq>) that we have captured from B<Test::Builder> against
+that that was declared with C<test_out> and C<test_err>.
+
+This takes name/value pairs that effect how the test is run.
+
+=over
+
+=item title (synonym 'name', 'label')
+
+The name of the test that will be displayed after the C<ok> or C<not
+ok>.
+
+=item skip_out
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the output stream does not match that
+declared with C<test_out>.
+
+=item skip_err
+
+Setting this to a true value will cause the test to ignore if the
+output sent by the test to the error stream does not match that
+declared with C<test_err>.
+
+=back
+
+As a convience, if only one argument is passed then this argument
+is assumed to be the name of the test (as in the above examples.)
+
+Once C<test_test> has been run test output will be redirected back to
+the original filehandles that B<Test::Builder> was connected to
+(probably STDOUT and STDERR,) meaning any further tests you run
+will function normally and cause success/errors for B<Test::Harness>.
+
+=cut
+
+sub test_test {
+ # decode the arguements as described in the pod
+ my $mess;
+ my %args;
+ if( @_ == 1 ) {
+ $mess = shift
+ }
+ else {
+ %args = @_;
+ $mess = $args{name} if exists( $args{name} );
+ $mess = $args{title} if exists( $args{title} );
+ $mess = $args{label} if exists( $args{label} );
+ }
+
+ # er, are we testing?
+ croak "Not testing. You must declare output with a test function first."
+ unless $testing;
+
+ # okay, reconnect the test suite back to the saved handles
+ $t->output($original_output_handle);
+ $t->failure_output($original_failure_handle);
+ $t->todo_output($original_todo_handle);
+
+ # restore the test no, etc, back to the original point
+ $t->current_test($testing_num);
+ $testing = 0;
+
+ # re-enable the original setting of the harness
+ $ENV{HARNESS_ACTIVE} = $original_harness_env;
+
+ # check the output we've stashed
+ unless( $t->ok( ( $args{skip_out} || $out->check ) &&
+ ( $args{skip_err} || $err->check ), $mess )
+ )
+ {
+ # print out the diagnostic information about why this
+ # test failed
+
+ local $_;
+
+ $t->diag( map { "$_\n" } $out->complaint )
+ unless $args{skip_out} || $out->check;
+
+ $t->diag( map { "$_\n" } $err->complaint )
+ unless $args{skip_err} || $err->check;
+ }
+}
+
+=item line_num
+
+A utility function that returns the line number that the function was
+called on. You can pass it an offset which will be added to the
+result. This is very useful for working out the correct text of
+diagnostic functions that contain line numbers.
+
+Essentially this is the same as the C<__LINE__> macro, but the
+C<line_num(+3)> idiom is arguably nicer.
+
+=cut
+
+sub line_num {
+ my( $package, $filename, $line ) = caller;
+ return $line + ( shift() || 0 ); # prevent warnings
+}
+
+=back
+
+In addition to the six exported functions there there exists one
+function that can only be accessed with a fully qualified function
+call.
+
+=over 4
+
+=item color
+
+When C<test_test> is called and the output that your tests generate
+does not match that which you declared, C<test_test> will print out
+debug information showing the two conflicting versions. As this
+output itself is debug information it can be confusing which part of
+the output is from C<test_test> and which was the original output from
+your original tests. Also, it may be hard to spot things like
+extraneous whitespace at the end of lines that may cause your test to
+fail even though the output looks similar.
+
+To assist you C<test_test> can colour the background of the debug
+information to disambiguate the different types of output. The debug
+output will have it's background coloured green and red. The green
+part represents the text which is the same between the executed and
+actual output, the red shows which part differs.
+
+The C<color> function determines if colouring should occur or not.
+Passing it a true or false value will enable or disable colouring
+respectively, and the function called with no argument will return the
+current setting.
+
+To enable colouring from the command line, you can use the
+B<Text::Builder::Tester::Color> module like so:
+
+ perl -Mlib=Text::Builder::Tester::Color test.t
+
+Or by including the B<Test::Builder::Tester::Color> module directly in
+the PERL5LIB.
+
+=cut
+
+my $color;
+
+sub color {
+ $color = shift if @_;
+ $color;
+}
+
+=back
+
+=head1 BUGS
+
+Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+This is needed as otherwise it will trip out because we've run more
+tests than we strictly should have and it'll register any failures we
+had that we were testing for as real failures.
+
+The color function doesn't work unless B<Term::ANSIColor> is
+compatible with your terminal.
+
+Bugs (and requests for new features) can be reported to the author
+though the CPAN RT system:
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+Some code taken from B<Test::More> and B<Test::Catch>, written by by
+Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts
+Copyright Micheal G Schwern 2001. Used and distributed with
+permission.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 NOTES
+
+Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
+me use his testing system to try this module out on.
+
+=head1 SEE ALSO
+
+L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
+
+=cut
+
+1;
+
+####################################################################
+# Helper class that is used to remember expected and received data
+
+package Test::Builder::Tester::Tie;
+
+##
+# add line(s) to be expected
+
+sub expect {
+ my $self = shift;
+
+ my @checks = @_;
+ foreach my $check (@checks) {
+ $check = $self->_translate_Failed_check($check);
+ push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
+ }
+}
+
+sub _translate_Failed_check {
+ my( $self, $check ) = @_;
+
+ if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
+ $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
+ }
+
+ return $check;
+}
+
+##
+# return true iff the expected data matches the got data
+
+sub check {
+ my $self = shift;
+
+ # turn off warnings as these might be undef
+ local $^W = 0;
+
+ my @checks = @{ $self->{wanted} };
+ my $got = $self->{got};
+ foreach my $check (@checks) {
+ $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
+ return 0 unless $got =~ s/^$check//;
+ }
+
+ return length $got == 0;
+}
+
+##
+# a complaint message about the inputs not matching (to be
+# used for debugging messages)
+
+sub complaint {
+ my $self = shift;
+ my $type = $self->type;
+ my $got = $self->got;
+ my $wanted = join "\n", @{ $self->wanted };
+
+ # are we running in colour mode?
+ if(Test::Builder::Tester::color) {
+ # get color
+ eval { require Term::ANSIColor };
+ unless($@) {
+ # colours
+
+ my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
+ my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
+ my $reset = Term::ANSIColor::color("reset");
+
+ # work out where the two strings start to differ
+ my $char = 0;
+ $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
+
+ # get the start string and the two end strings
+ my $start = $green . substr( $wanted, 0, $char );
+ my $gotend = $red . substr( $got, $char ) . $reset;
+ my $wantedend = $red . substr( $wanted, $char ) . $reset;
+
+ # make the start turn green on and off
+ $start =~ s/\n/$reset\n$green/g;
+
+ # make the ends turn red on and off
+ $gotend =~ s/\n/$reset\n$red/g;
+ $wantedend =~ s/\n/$reset\n$red/g;
+
+ # rebuild the strings
+ $got = $start . $gotend;
+ $wanted = $start . $wantedend;
+ }
+ }
+
+ return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
+}
+
+##
+# forget all expected and got data
+
+sub reset {
+ my $self = shift;
+ %$self = (
+ type => $self->{type},
+ got => '',
+ wanted => [],
+ );
+}
+
+sub got {
+ my $self = shift;
+ return $self->{got};
+}
+
+sub wanted {
+ my $self = shift;
+ return $self->{wanted};
+}
+
+sub type {
+ my $self = shift;
+ return $self->{type};
+}
+
+###
+# tie interface
+###
+
+sub PRINT {
+ my $self = shift;
+ $self->{got} .= join '', @_;
+}
+
+sub TIEHANDLE {
+ my( $class, $type ) = @_;
+
+ my $self = bless { type => $type }, $class;
+
+ $self->reset;
+
+ return $self;
+}
+
+sub READ { }
+sub READLINE { }
+sub GETC { }
+sub FILENO { }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm
new file mode 100644
index 00000000000..264fddbfd86
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm
@@ -0,0 +1,51 @@
+package Test::Builder::Tester::Color;
+
+use strict;
+our $VERSION = "1.18";
+
+require Test::Builder::Tester;
+
+
+=head1 NAME
+
+Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
+
+=head1 SYNOPSIS
+
+ When running a test script
+
+ perl -MTest::Builder::Tester::Color test.t
+
+=head1 DESCRIPTION
+
+Importing this module causes the subroutine color in Test::Builder::Tester
+to be called with a true value causing colour highlighting to be turned
+on in debug output.
+
+The sole purpose of this module is to enable colour highlighting
+from the command line.
+
+=cut
+
+sub import {
+ Test::Builder::Tester::color(1);
+}
+
+=head1 AUTHOR
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=head1 BUGS
+
+This module will have no effect unless Term::ANSIColor is installed.
+
+=head1 SEE ALSO
+
+L<Test::Builder::Tester>, L<Term::ANSIColor>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test/Harness.pm b/Master/tlpkg/tlperl/lib/Test/Harness.pm
new file mode 100644
index 00000000000..eba3c5efc4a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Harness.pm
@@ -0,0 +1,585 @@
+package Test::Harness;
+
+require 5.00405;
+
+use strict;
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
+
+use TAP::Parser::Utils qw( split_shell );
+
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+ $IgnoreExit
+);
+
+# $ML $Last_ML_Print
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
+
+=head1 NAME
+
+Test::Harness - Run Perl standard test scripts with statistics
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+# Backwards compatibility for exportable variable names.
+*verbose = *Verbose;
+*switches = *Switches;
+*debug = *Debug;
+
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
+
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
+
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
+
+=head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
+
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
+
+=head1 FUNCTIONS
+
+The following functions are available.
+
+=head2 runtests( @test_files )
+
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+out each individual test which failed along with a summary report and
+a how long it all took.
+
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
+
+=cut
+
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
+
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
+
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
+
+ _apply_extra_INC($harness);
+ _aggregate_tests( $harness, $aggregate, @tests );
+}
+
+# Make sure the child seens all the extra junk in @INC
+sub _apply_extra_INC {
+ my $harness = shift;
+
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ );
+}
+
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
+
+}
+
+sub runtests {
+ my @tests = @_;
+
+ # shield against -l
+ local ( $\, $, );
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ _aggregate( $harness, $aggregate, @tests );
+
+ $harness->formatter->summary($aggregate);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
+
+ my @parsers = $aggregate->parsers;
+
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
+
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
+
+ return $total && $total == $passed;
+}
+
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
+
+ return join( ' ', @ranges );
+}
+
+sub _new_harness {
+ my $sub_args = shift || {};
+
+ my ( @lib, @switches );
+ my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} );
+ while ( my $opt = shift @opt ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, length($1) ? $1 : shift @opt;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
+
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ ignore_exit => $IgnoreExit,
+ };
+
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
+
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'c' ) {
+ $args->{color} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
+ }
+
+ return TAP::Harness->new($args);
+}
+
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
+
+ if (IS_VMS) {
+
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
+
+ }
+ elsif (IS_WIN32) {
+
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/]+$// foreach @inc;
+ }
+
+ my @default_inc = _default_inc();
+
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
+
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
+
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
+
+ return @new_inc;
+}
+
+{
+
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
+
+ sub _default_inc {
+ return @inc if @inc;
+
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB};
+
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+
+ # Avoid using -l for the benefit of Perl 6
+ chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` );
+ return @inc;
+ }
+}
+
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
+
+ return 1;
+}
+
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ # harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
+
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
+
+ return ( \%tot, \%failedtests, \%todo_passed );
+}
+
+=head2 execute_tests( tests => \@test_files, out => \*FH )
+
+Runs all the given C<@test_files> (just like C<runtests()>) but
+doesn't generate the final report. During testing, progress
+information will be written to the currently selected output
+filehandle (usually C<STDOUT>), or to the filehandle given by the
+C<out> parameter. The I<out> is optional.
+
+Returns a list of two values, C<$total> and C<$failed>, describing the
+results. C<$total> is a hash ref summary of all the tests run. Its
+keys and values are this:
+
+ bonus Number of individual todo tests unexpectedly passed
+ max Number of individual tests ran
+ ok Number of individual tests passed
+ sub_skipped Number of individual tests skipped
+ todo Number of individual todo tests
+
+ files Number of test files ran
+ good Number of test files passed
+ bad Number of test files failed
+ tests Number of test files originally given
+ skipped Number of test files skipped
+
+If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
+got a successful test.
+
+C<$failed> is a hash ref of all the test scripts that failed. Each key
+is the name of a test script, each value is another hash representing
+how that script failed. Its keys are these:
+
+ name Name of the test which failed
+ estat Script's exit value
+ wstat Script's wait status
+ max Number of individual tests
+ failed Number which failed
+ canon List of tests which failed (as string).
+
+C<$failed> should be empty if everything passed.
+
+=cut
+
+1;
+__END__
+
+=head1 EXPORT
+
+C<&runtests> is exported by C<Test::Harness> by default.
+
+C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
+exported upon request.
+
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
+
+C<Test::Harness> sets these before executing the individual tests.
+
+=over 4
+
+=item C<HARNESS_ACTIVE>
+
+This is set to a true value. It allows the tests to determine if they
+are being executed through the harness or by any other means.
+
+=item C<HARNESS_VERSION>
+
+This is the version of C<Test::Harness>.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
+
+=over 4
+
+=item C<HARNESS_TIMER>
+
+Setting this to true will make the harness display the number of
+milliseconds each test took. You can also use F<prove>'s C<--timer>
+switch.
+
+=item C<HARNESS_VERBOSE>
+
+If true, C<Test::Harness> will output the verbose results of running
+its tests. Setting C<$Test::Harness::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
+
+=item C<HARNESS_OPTIONS>
+
+Provide additional options to the harness. Currently supported options are:
+
+=over
+
+=item C<< j<n> >>
+
+Run <n> (default 9) parallel jobs.
+
+=item C<< f >>
+
+Use forked parallelism.
+
+=back
+
+Multiple options may be separated by colons:
+
+ HARNESS_OPTIONS=j9:f make test
+
+=back
+
+=head1 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> (actually
+L<TAP::Parser::Source::Perl>) passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even in taint mode.
+
+=head1 SEE ALSO
+
+L<TAP::Harness>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-harness at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
+
+=head1 AUTHORS
+
+Andy Armstrong C<< <andy@hexten.net> >>
+
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
+
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
diff --git a/Master/tlpkg/tlperl/lib/Test/More.pm b/Master/tlpkg/tlperl/lib/Test/More.pm
new file mode 100644
index 00000000000..67284874698
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/More.pm
@@ -0,0 +1,1776 @@
+package Test::More;
+
+use 5.006;
+use strict;
+use warnings;
+
+#---- perlcritic exemptions. ----#
+
+# We use a lot of subroutine prototypes
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my( $file, $line ) = ( caller(1) )[ 1, 2 ];
+ return warn @_, " at $file line $line\n";
+}
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ done_testing
+ can_ok isa_ok new_ok
+ diag note explain
+ subtest
+ BAIL_OUT
+);
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 23;
+ # or
+ use Test::More skip_all => $reason;
+ # or
+ use Test::More; # see done_testing()
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($got eq $expected, $test_name);
+
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
+
+ cmp_ok($got, '==', $expected, $test_name);
+
+ is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ BAIL_OUT($why);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+L<Test::Simple> first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => 23;
+
+There are cases when you will not know beforehand how many tests your
+script is going to run. In this case, you can declare your tests at
+the end.
+
+ use Test::More;
+
+ ... run your tests ...
+
+ done_testing( $number_of_tests_run );
+
+Sometimes you really don't know how many tests were run, or it's too
+difficult to calculate. In which case you can leave off
+$number_of_tests_run.
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my $tb = Test::More->builder;
+
+ return $tb->plan(@_);
+}
+
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
+
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
+
+ if( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
+ }
+ else {
+ push @other, $item;
+ }
+
+ $idx++;
+ }
+
+ @$list = @other;
+
+ return;
+}
+
+=over 4
+
+=item B<done_testing>
+
+ done_testing();
+ done_testing($number_of_tests);
+
+If you don't know how many tests you're going to run, you can issue
+the plan when you're done running tests.
+
+$number_of_tests is the same as plan(), it's the number of tests you
+expected to run. You can omit this, in which case the number of tests
+you ran doesn't matter, just the fact that your tests ran to
+conclusion.
+
+This is safer than and replaces the "no_plan" plan.
+
+=back
+
+=cut
+
+sub done_testing {
+ my $tb = Test::More->builder;
+ $tb->done_testing(@_);
+}
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($got eq $expected, $test_name);
+
+This simply evaluates any expression (C<$got eq $expected> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
+
+This is the same as Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my( $test, $name ) = @_;
+ my $tb = Test::More->builder;
+
+ return $tb->ok( $test, $name );
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $got, $expected, $test_name );
+ isnt( $got, $expected, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
+
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
+
+A simple call to isnt() usually does not provide a strong test but there
+are cases when you cannot say much more about a value than that it is
+different from some other value:
+
+ new_ok $obj, "Foo";
+
+ my $clone = $obj->clone;
+ isa_ok $obj, "Foo", "Foo->clone";
+
+ isnt $obj, $clone, "clone() produces a different object";
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+=item B<like>
+
+ like( $got, qr/expected/, $test_name );
+
+Similar to ok(), like() matches $got against the regex C<qr/expected/>.
+
+So this:
+
+ like($got, qr/expected/, 'this is like that');
+
+is similar to:
+
+ ok( $got =~ /expected/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $got, '/expected/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/expected/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->like(@_);
+}
+
+=item B<unlike>
+
+ unlike( $got, qr/expected/, $test_name );
+
+Works exactly as like(), only it checks if $got B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike ($$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->unlike(@_);
+}
+
+=item B<cmp_ok>
+
+ cmp_ok( $got, $op, $expected, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $got eq $expected );
+ cmp_ok( $got, 'eq', $expected, 'this eq that' );
+
+ # ok( $got == $expected );
+ cmp_ok( $got, '==', $expected, 'this == that' );
+
+ # ok( $got && $expected );
+ cmp_ok( $got, '&&', $expected, 'this && that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $got
+and $expected were:
+
+ not ok 1
+ # Failed test in foo.t at line 12.
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+It's especially useful when comparing greater-than or smaller-than
+relation between values:
+
+ cmp_ok( $some_value, '<=', $upper_limit );
+
+
+=cut
+
+sub cmp_ok($$$;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->cmp_ok(@_);
+}
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my( $proto, @methods ) = @_;
+ my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
+
+ unless($class) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
+ unless(@methods) {
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
+ }
+
+ my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
+ "$class->can(...)" ;
+
+ my $ok = $tb->ok( !@nok, $name );
+
+ $tb->diag( map " $class->can('$_') failed\n", @nok );
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($subclass, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+You can also test a class, to make sure that it has the right ancestor:
+
+ isa_ok( 'Vole', 'Rodent' );
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my( $object, $class, $obj_name ) = @_;
+ my $tb = Test::More->builder;
+
+ my $diag;
+
+ if( !defined $object ) {
+ $obj_name = 'The thing' unless defined $obj_name;
+ $diag = "$obj_name isn't defined";
+ }
+ else {
+ my $whatami = ref $object ? 'object' : 'class';
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
+ if($error) {
+ if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+ # Its 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'";
+ }
+ }
+ 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 $whatami and got some weird error.
+Here's the error.
+$error
+WHOA
+ }
+ }
+ else {
+ $obj_name = "The $whatami" unless defined $obj_name;
+ if( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+ }
+
+ my $name = "$obj_name isa $class";
+ my $ok;
+ if($diag) {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
+ else {
+ $ok = $tb->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+=item B<new_ok>
+
+ my $obj = new_ok( $class );
+ my $obj = new_ok( $class => \@args );
+ my $obj = new_ok( $class => \@args, $object_name );
+
+A convenience function which combines creating an object and calling
+isa_ok() on that object.
+
+It is basically equivalent to:
+
+ my $obj = $class->new(@args);
+ isa_ok $obj, $class, $object_name;
+
+If @args is not given, an empty list will be used.
+
+This function only works on new() and it assumes new() will return
+just a single object which isa C<$class>.
+
+=cut
+
+sub new_ok {
+ my $tb = Test::More->builder;
+ $tb->croak("new_ok() must be given at least a class") unless @_;
+
+ my( $class, $args, $object_name ) = @_;
+
+ $args ||= [];
+ $object_name = "The object" unless defined $object_name;
+
+ my $obj;
+ my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
+ if($success) {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ isa_ok $obj, $class, $object_name;
+ }
+ else {
+ $tb->ok( 0, "new() died" );
+ $tb->diag(" Error was: $error");
+ }
+
+ return $obj;
+}
+
+=item B<subtest>
+
+ subtest $name => \&code;
+
+subtest() runs the &code as its own little test with its own plan and
+its own result. The main test counts this as a single test using the
+result of the whole subtest to determine if its ok or not ok.
+
+For example...
+
+ use Test::More tests => 3;
+
+ pass("First test");
+
+ subtest 'An example subtest' => sub {
+ plan tests => 2;
+
+ pass("This is a subtest");
+ pass("So is this");
+ };
+
+ pass("Third test");
+
+This would produce.
+
+ 1..3
+ ok 1 - First test
+ 1..2
+ ok 1 - This is a subtest
+ ok 2 - So is this
+ ok 2 - An example subtest
+ ok 3 - Third test
+
+A subtest may call "skip_all". No tests will be run, but the subtest is
+considered a skip.
+
+ subtest 'skippy' => sub {
+ plan skip_all => 'cuz I said so';
+ pass('this test will never be run');
+ };
+
+Returns true if the subtest passed, false otherwise.
+
+=cut
+
+sub subtest($&) {
+ my ($name, $subtests) = @_;
+
+ my $tb = Test::More->builder;
+ return $tb->subtest(@_);
+}
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 1, @_ );
+}
+
+sub fail (;$) {
+ my $tb = Test::More->builder;
+
+ return $tb->ok( 0, @_ );
+}
+
+=back
+
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my( $module, @imports ) = @_;
+ @imports = () unless @imports;
+ my $tb = Test::More->builder;
+
+ my( $pack, $filename, $line ) = caller;
+
+ my $code;
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ $code = <<USE;
+package $pack;
+use $module $imports[0];
+1;
+USE
+ }
+ else {
+ $code = <<USE;
+package $pack;
+use $module \@{\$args[0]};
+1;
+USE
+ }
+
+ my( $eval_result, $eval_error ) = _eval( $code, \@imports );
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _eval {
+ my( $code, @args ) = @_;
+
+ # Work around oddities surrounding resetting of $@ by immediately
+ # storing it.
+ my( $sigdie, $eval_result, $eval_error );
+ {
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ $eval_error = $@;
+ $sigdie = $SIG{__DIE__} || undef;
+ }
+ # make sure that $code got a chance to set $SIG{__DIE__}
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
+
+ return( $eval_result, $eval_error );
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+ require_ok($file);
+
+Like use_ok(), except it requires the $module or $file.
+
+=cut
+
+sub require_ok ($) {
+ my($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my $code = <<REQUIRE;
+package $pack;
+require $module;
+1;
+REQUIRE
+
+ my( $eval_result, $eval_error ) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+=back
+
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $got, $expected, $test_name );
+
+Similar to is(), except that if $got and $expected are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+is_deeply() currently has very limited handling of function reference
+and globs. It merely checks if they have the same referent. This may
+improve in the future.
+
+L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
+along these lines.
+
+=cut
+
+our( @Data_Stack, %Refs_Seen );
+my $DNE = bless [], 'Does::Not::Exist';
+
+sub _dne {
+ return ref $_[0] eq ref $DNE;
+}
+
+## no critic (Subroutines::RequireArgUnpacking)
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<'WARNING';
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my( $got, $expected, $name ) = @_;
+
+ $tb->_unoverload_str( \$expected, \$got );
+
+ my $ok;
+ if( !ref $got and !ref $expected ) { # neither is a reference
+ $ok = $tb->is_eq( $got, $expected, $name );
+ }
+ elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check( $got, $expected ) ) {
+ $ok = $tb->ok( 1, $name );
+ }
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag( _format_stack(@Data_Stack) );
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
+ my @vars = ();
+ ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
+ ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx ( 0 .. $#vals ) {
+ my $val = $vals[$idx];
+ $vals[$idx]
+ = !defined $val ? 'undef'
+ : _dne($val) ? "Does not exist"
+ : ref $val ? "$val"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ return $type if UNIVERSAL::isa( $thing, $type );
+ }
+
+ return '';
+}
+
+=back
+
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Returns false, so as to preserve failure.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=item B<note>
+
+ note(@diagnostic_message);
+
+Like diag(), except the message will not be seen when the test is run
+in a harness. It will only be visible in the verbose TAP stream.
+
+Handy for putting in notes which might be useful for debugging, but
+don't indicate a problem.
+
+ note("Tempfile is $tempfile");
+
+=cut
+
+sub diag {
+ return Test::More->builder->diag(@_);
+}
+
+sub note {
+ return Test::More->builder->note(@_);
+}
+
+=item B<explain>
+
+ my @dump = explain @diagnostic_message;
+
+Will dump the contents of any references in a human readable format.
+Usually you want to pass this into C<note> or C<diag>.
+
+Handy for things like...
+
+ is_deeply($have, $want) || diag explain $have;
+
+or
+
+ note explain \%args;
+ Some::Class->method(%args);
+
+=cut
+
+sub explain {
+ return Test::More->builder->explain(@_);
+}
+
+=back
+
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+## no critic (Subroutines::RequireFinalReturn)
+sub skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ if( defined $how_many and $how_many =~ /\D/ ) {
+ _carp
+ "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->skip($why);
+ }
+
+ no warnings 'exiting';
+ last SKIP;
+}
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my( $why, $how_many ) = @_;
+ my $tb = Test::More->builder;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $tb->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1 .. $how_many ) {
+ $tb->todo_skip($why);
+ }
+
+ no warnings 'exiting';
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+
+=head2 Test control
+
+=over 4
+
+=item B<BAIL_OUT>
+
+ BAIL_OUT($reason);
+
+Indicates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
+
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
+
+The test will exit with 255.
+
+For even better control look at L<Test::Most>.
+
+=cut
+
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
+
+ $tb->BAIL_OUT($reason);
+}
+
+=back
+
+
+=head2 Discouraged comparison functions
+
+The use of the following functions is discouraged as they are not
+actually testing functions and produce no diagnostics to help figure
+out what went wrong. They were written before is_deeply() existed
+because I couldn't figure out how to display a useful diff of two
+arbitrary data structures.
+
+These functions are usually used inside an ok().
+
+ ok( eq_array(\@got, \@expected) );
+
+C<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@got, \@expected );
+
+They may be deprecated in future versions.
+
+=over 4
+
+=item B<eq_array>
+
+ my $is_eq = eq_array(\@got, \@expected);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ local @Data_Stack = ();
+ _deep_check(@_);
+}
+
+sub _eq_array {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for( 0 .. $max ) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _deep_check {
+ my( $e1, $e2 ) = @_;
+ my $tb = Test::More->builder;
+
+ my $ok = 0;
+
+ # Effectively turn %Refs_Seen into a stack. This avoids picking up
+ # the same referenced used twice (such as [\$a, \$a]) to be considered
+ # circular.
+ local %Refs_Seen = %Refs_Seen;
+
+ {
+ # Quiet uninitialized value warnings when comparing undefs.
+ no warnings 'uninitialized';
+
+ $tb->_unoverload_str( \$e1, \$e2 );
+
+ # Either they're both references or both not.
+ my $same_ref = !( !ref $e1 xor !ref $e2 );
+ my $not_ref = ( !ref $e1 and !ref $e2 );
+
+ if( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif( !defined $e1 and !defined $e2 ) {
+ # Shortcut if they're both defined.
+ $ok = 1;
+ }
+ elsif( _dne($e1) xor _dne($e2) ) {
+ $ok = 0;
+ }
+ elsif( $same_ref and( $e1 eq $e2 ) ) {
+ $ok = 1;
+ }
+ elsif($not_ref) {
+ push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ if( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
+ }
+ else {
+ $Refs_Seen{$e1} = "$e2";
+ }
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array( $e1, $e2 );
+ }
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash( $e1, $e2 );
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $$e1, $$e2 );
+ pop @Data_Stack if $ok;
+ }
+ elsif($type) {
+ push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+ $ok = 0;
+ }
+ else {
+ _whoa( 1, "No type in _deep_check" );
+ }
+ }
+ }
+
+ return $ok;
+}
+
+sub _whoa {
+ my( $check, $desc ) = @_;
+ if($check) {
+ die <<"WHOA";
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<eq_hash>
+
+ my $is_eq = eq_hash(\%got, \%expected);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ local @Data_Stack = ();
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
+ my( $a1, $a2 ) = @_;
+
+ if( grep _type($_) ne 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k ( keys %$bigger ) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
+ $ok = _deep_check( $e1, $e2 );
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ my $is_eq = eq_set(\@got, \@expected);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+ ok( eq_set(\@got, \@expected) );
+
+Is better written:
+
+ is_deeply( [sort @got], [sort @expected] );
+
+B<NOTE> By historical accident, this is not a true set comparison.
+While the order of elements does not matter, duplicate elements do.
+
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
+L<Test::Deep> contains much better set comparison functions.
+
+=cut
+
+sub eq_set {
+ my( $a1, $a2 ) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ no warnings 'uninitialized';
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return eq_array(
+ [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
+ [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
+ );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+
+=back
+
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
+
+
+=head1 CAVEATS and NOTES
+
+=over 4
+
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.6.0.
+
+
+=item utf8 / "Wide character in print"
+
+If you use utf8 or other non-ASCII characters with Test::More you
+might get a "Wide character in print" warning. Using C<binmode
+STDOUT, ":utf8"> will not fix it. Test::Builder (which powers
+Test::More) duplicates STDOUT and STDERR. So any changes to them,
+including changing their output disciplines, will not be seem by
+Test::More.
+
+The work around is to change the filehandles used by Test::Builder
+directly.
+
+ my $builder = Test::More->builder;
+ binmode $builder->output, ":utf8";
+ binmode $builder->failure_output, ":utf8";
+ binmode $builder->todo_output, ":utf8";
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest L<Test::Deep> which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+5.8.1 and above are supported. Anything below that has too many bugs.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test::Harness> is the test runner and output interpreter for Perl.
+It's the thing that powers C<make test> and where the C<prove> utility
+comes from.
+
+L<Test::Legacy> tests written with Test.pm, the original testing
+module, do not play well with other testing libraries. Test::Legacy
+emulates the Test.pm interface and does play well with others.
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like xUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<Bundle::Test> installs a whole bunch of useful test modules.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
+
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/schwern/test-more/>.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test/Simple.pm b/Master/tlpkg/tlperl/lib/Test/Simple.pm
new file mode 100644
index 00000000000..9c8716759a4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Simple.pm
@@ -0,0 +1,214 @@
+package Test::Simple;
+
+use 5.006;
+
+use strict;
+
+our $VERSION = '0.94';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Builder::Module;
+our @ISA = qw(Test::Builder::Module);
+our @EXPORT = qw(ok);
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+Test::Simple - Basic utilities for writing tests.
+
+=head1 SYNOPSIS
+
+ use Test::Simple tests => 1;
+
+ ok( $foo eq $bar, 'foo is bar' );
+
+
+=head1 DESCRIPTION
+
+** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+
+This is an extremely simple, extremely basic module for writing tests
+suitable for CPAN modules and other pursuits. If you wish to do more
+complicated testing, use the Test::More module (a drop-in replacement
+for this one).
+
+The basic unit of Perl testing is the ok. For each thing you want to
+test your program will print out an "ok" or "not ok" to indicate pass
+or fail. You do this with the ok() function (see below).
+
+The only other constraint is you must pre-declare how many tests you
+plan to run. This is in case something goes horribly wrong during the
+test and your test program aborts, or skips a test or whatever. You
+do this like so:
+
+ use Test::Simple tests => 23;
+
+You must have a plan.
+
+
+=over 4
+
+=item B<ok>
+
+ ok( $foo eq $bar, $name );
+ ok( $foo eq $bar );
+
+ok() is given an expression (in this case C<$foo eq $bar>). If it's
+true, the test passed. If it's false, it didn't. That's about it.
+
+ok() prints out either "ok" or "not ok" along with a test number (it
+keeps track of that for you).
+
+ # This produces "ok 1 - Hell not yet frozen over" (or not ok)
+ ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
+
+If you provide a $name, that will be printed along with the "ok/not
+ok" to make it easier to find your test when if fails (just search for
+the name). It also makes it easier for the next guy to understand
+what your test is for. It's highly recommended you use test names.
+
+All tests are run in scalar context. So this:
+
+ ok( @stuff, 'I have some stuff' );
+
+will do what you mean (fail if stuff is empty)
+
+=cut
+
+sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
+ return $CLASS->builder->ok(@_);
+}
+
+=back
+
+Test::Simple will start by printing number of tests run in the form
+"1..M" (so "1..5" means you're going to run 5 tests). This strange
+format lets Test::Harness know how many tests you plan on running in
+case something goes horribly wrong.
+
+If all your tests passed, Test::Simple will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Simple
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+This module is by no means trying to be a complete testing system.
+It's just to get you started. Once you're off the ground its
+recommended you look at L<Test::More>.
+
+
+=head1 EXAMPLE
+
+Here's an example of a simple .t file for the fictional Film module.
+
+ use Test::Simple tests => 5;
+
+ use Film; # What you're testing.
+
+ my $btaste = Film->new({ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1
+ });
+ ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' );
+
+ ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
+ ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Rating eq 'R', 'Rating() get' );
+ ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
+
+It will produce output like this:
+
+ 1..5
+ ok 1 - new() works
+ ok 2 - Title() get
+ ok 3 - Director() get
+ not ok 4 - Rating() get
+ # Failed test 'Rating() get'
+ # in t/film.t at line 14.
+ ok 5 - NumExplodingSheep() get
+ # Looks like you failed 1 tests of 5
+
+Indicating the Film::Rating() method is broken.
+
+
+=head1 CAVEATS
+
+Test::Simple will only report a maximum of 254 failures in its exit
+code. If this is a problem, you probably have a huge test script.
+Split it into multiple files. (Otherwise blame the Unix folks for
+using an unsigned short integer as the exit status).
+
+Because VMS's exit codes are much, much different than the rest of the
+universe, and perl does horrible mangling to them that gets in my way,
+it works like this on VMS.
+
+ 0 SS$_NORMAL all tests successful
+ 4 SS$_ABORT something went wrong
+
+Unfortunately, I can't differentiate any further.
+
+
+=head1 NOTES
+
+Test::Simple is B<explicitly> tested all the way back to perl 5.6.0.
+
+Test::Simple is thread-safe in perl 5.8.1 and up.
+
+=head1 HISTORY
+
+This module was conceived while talking with Tony Bowden in his
+kitchen one night about the problems I was having writing some really
+complicated feature into the new Testing module. He observed that the
+main problem is not dealing with these edge cases but that people hate
+to write tests B<at all>. What was needed was a dead simple module
+that took all the hard work out of testing and was really, really easy
+to learn. Paul Johnson simultaneously had this idea (unfortunately,
+he wasn't in Tony's kitchen). This is it.
+
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::More>
+
+More testing functions! Once you outgrow Test::Simple, look at
+Test::More. Test::Simple is 100% forward compatible with Test::More
+(i.e. you can just use Test::More instead of Test::Simple in your
+programs and things will still work).
+
+=back
+
+Look in Test::More's SEE ALSO for more testing modules.
+
+
+=head1 AUTHORS
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test/Tutorial.pod b/Master/tlpkg/tlperl/lib/Test/Tutorial.pod
new file mode 100644
index 00000000000..46ac467ddae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Tutorial.pod
@@ -0,0 +1,604 @@
+=head1 NAME
+
+Test::Tutorial - A tutorial about writing really basic tests
+
+=head1 DESCRIPTION
+
+
+I<AHHHHHHH!!!! NOT TESTING! Anything but testing!
+Beat me, whip me, send me to Detroit, but don't make
+me write tests!>
+
+I<*sob*>
+
+I<Besides, I don't know how to write the damned things.>
+
+
+Is this you? Is writing tests right up there with writing
+documentation and having your fingernails pulled out? Did you open up
+a test and read
+
+ ######## We start with some black magic
+
+and decide that's quite enough for you?
+
+It's ok. That's all gone now. We've done all the black magic for
+you. And here are the tricks...
+
+
+=head2 Nuts and bolts of testing.
+
+Here's the most basic test program.
+
+ #!/usr/bin/perl -w
+
+ print "1..1\n";
+
+ print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";
+
+since 1 + 1 is 2, it prints:
+
+ 1..1
+ ok 1
+
+What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
+"The first test passed". And that's about all magic there is to
+testing. Your basic unit of testing is the I<ok>. For each thing you
+test, an C<ok> is printed. Simple. B<Test::Harness> interprets your test
+results to determine if you succeeded or failed (more on that later).
+
+Writing all these print statements rapidly gets tedious. Fortunately,
+there's B<Test::Simple>. It has one function, C<ok()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 1;
+
+ ok( 1 + 1 == 2 );
+
+and that does the same thing as the code above. C<ok()> is the backbone
+of Perl testing, and we'll be using it instead of roll-your-own from
+here on. If C<ok()> gets a true value, the test passes. False, it
+fails.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+ ok( 1 + 1 == 2 );
+ ok( 2 + 2 == 5 );
+
+from that comes
+
+ 1..2
+ ok 1
+ not ok 2
+ # Failed test (test.pl at line 5)
+ # Looks like you failed 1 tests of 2.
+
+C<1..2> "I'm going to run two tests." This number is used to ensure
+your test program ran all the way through and didn't die or skip some
+tests. C<ok 1> "The first test passed." C<not ok 2> "The second test
+failed". Test::Simple helpfully prints out some extra commentary about
+your tests.
+
+It's not scary. Come, hold my hand. We're going to give an example
+of testing a module. For our example, we'll be testing a date
+library, B<Date::ICal>. It's on CPAN, so download a copy and follow
+along. [2]
+
+
+=head2 Where to start?
+
+This is the hardest part of testing, where do you start? People often
+get overwhelmed at the apparent enormity of the task of testing a
+whole module. Best place to start is at the beginning. Date::ICal is
+an object-oriented module, and that means you start by making an
+object. So we test C<new()>.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 2;
+
+ use Date::ICal;
+
+ my $ical = Date::ICal->new; # create an object
+ ok( defined $ical ); # check that we got something
+ ok( $ical->isa('Date::ICal') ); # and it's the right class
+
+run that and you should get:
+
+ 1..2
+ ok 1
+ ok 2
+
+congratulations, you've written your first useful test.
+
+
+=head2 Names
+
+That output isn't terribly descriptive, is it? When you have two
+tests you can figure out which one is #2, but what if you have 102?
+
+Each test can be given a little descriptive name as the second
+argument to C<ok()>.
+
+ use Test::Simple tests => 2;
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+So now you'd see...
+
+ 1..2
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+
+
+=head2 Test the manual
+
+Simplest way to build up a decent testing suite is to just test what
+the manual says it does. [3] Let's pull something out of the
+L<Date::ICal/SYNOPSIS> and test that all its bits work.
+
+ #!/usr/bin/perl -w
+
+ use Test::Simple tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ ok( $ical->sec == 47, ' sec()' );
+ ok( $ical->min == 12, ' min()' );
+ ok( $ical->hour == 16, ' hour()' );
+ ok( $ical->day == 17, ' day()' );
+ ok( $ical->month == 10, ' month()' );
+ ok( $ical->year == 1964, ' year()' );
+
+run that and you get:
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+Whoops, a failure! [4] Test::Simple helpfully lets us know on what line
+the failure occurred, but not much else. We were supposed to get 17,
+but we didn't. What did we get?? Dunno. We'll have to re-run the
+test in the debugger or throw in some print statements to find out.
+
+Instead, we'll switch from B<Test::Simple> to B<Test::More>. B<Test::More>
+does everything B<Test::Simple> does, and more! In fact, Test::More does
+things I<exactly> the way Test::Simple does. You can literally swap
+Test::Simple out and put Test::More in its place. That's just what
+we're going to do.
+
+Test::More does more than Test::Simple. The most important difference
+at this point is it provides more informative ways to say "ok".
+Although you can write almost any test with a generic C<ok()>, it
+can't tell you what went wrong. Instead, we'll use the C<is()>
+function, which lets us declare that something is supposed to be the
+same as something else:
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 8;
+
+ use Date::ICal;
+
+ $ical = Date::ICal->new( year => 1964, month => 10, day => 16,
+ hour => 16, min => 12, sec => 47,
+ tz => '0530' );
+
+ ok( defined $ical, 'new() returned something' );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+ is( $ical->sec, 47, ' sec()' );
+ is( $ical->min, 12, ' min()' );
+ is( $ical->hour, 16, ' hour()' );
+ is( $ical->day, 17, ' day()' );
+ is( $ical->month, 10, ' month()' );
+ is( $ical->year, 1964, ' year()' );
+
+"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place,
+you get some more information
+
+ 1..8
+ ok 1 - new() returned something
+ ok 2 - and it's the right class
+ ok 3 - sec()
+ ok 4 - min()
+ ok 5 - hour()
+ not ok 6 - day()
+ # Failed test (- at line 16)
+ # got: '16'
+ # expected: '17'
+ ok 7 - month()
+ ok 8 - year()
+ # Looks like you failed 1 tests of 8.
+
+letting us know that C<$ical-E<gt>day> returned 16, but we expected 17. A
+quick check shows that the code is working fine, we made a mistake
+when writing up the tests. Just change it to:
+
+ is( $ical->day, 16, ' day()' );
+
+and everything works.
+
+So any time you're doing a "this equals that" sort of test, use C<is()>.
+It even works on arrays. The test is always in scalar context, so you
+can test how many elements are in a list this way. [5]
+
+ is( @foo, 5, 'foo has 5 elements' );
+
+
+=head2 Sometimes the tests are wrong
+
+Which brings us to a very important lesson. Code has bugs. Tests are
+code. Ergo, tests have bugs. A failing test could mean a bug in the
+code, but don't discount the possibility that the test is wrong.
+
+On the flip side, don't be tempted to prematurely declare a test
+incorrect just because you're having trouble finding the bug.
+Invalidating a test isn't something to be taken lightly, and don't use
+it as a cop out to avoid work.
+
+
+=head2 Testing lots of values
+
+We're going to be wanting to test a lot of dates here, trying to trick
+the code with lots of different edge cases. Does it work before 1970?
+After 2038? Before 1904? Do years after 10,000 give it trouble?
+Does it get leap years right? We could keep repeating the code above,
+or we could set up a little try/expect loop.
+
+ use Test::More tests => 32;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ # An ICal string And the year, month, day
+ # hour, minute and second we expect.
+ '19971024T120000' => # from the docs.
+ [ 1997, 10, 24, 12, 0, 0 ],
+ '20390123T232832' => # after the Unix epoch
+ [ 2039, 1, 23, 23, 28, 32 ],
+ '19671225T000000' => # before the Unix epoch
+ [ 1967, 12, 25, 0, 0, 0 ],
+ '18990505T232323' => # before the MacOS epoch
+ [ 1899, 5, 5, 23, 23, 23 ],
+ );
+
+
+ while( my($ical_str, $expect) = each %ICal_Dates ) {
+ my $ical = Date::ICal->new( ical => $ical_str );
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+ ok( $ical->isa('Date::ICal'), " and it's the right class" );
+
+ is( $ical->year, $expect->[0], ' year()' );
+ is( $ical->month, $expect->[1], ' month()' );
+ is( $ical->day, $expect->[2], ' day()' );
+ is( $ical->hour, $expect->[3], ' hour()' );
+ is( $ical->min, $expect->[4], ' min()' );
+ is( $ical->sec, $expect->[5], ' sec()' );
+ }
+
+So now we can test bunches of dates by just adding them to
+C<%ICal_Dates>. Now that it's less work to test with more dates, you'll
+be inclined to just throw more in as you think of them.
+Only problem is, every time we add to that we have to keep adjusting
+the C<use Test::More tests =E<gt> ##> line. That can rapidly get
+annoying. There's two ways to make this work better.
+
+First, we can calculate the plan dynamically using the C<plan()>
+function.
+
+ use Test::More;
+ use Date::ICal;
+
+ my %ICal_Dates = (
+ ...same as before...
+ );
+
+ # For each key in the hash we're running 8 tests.
+ plan tests => keys(%ICal_Dates) * 8;
+
+ ...and then your tests...
+
+Or to be even more flexible, we use C<no_plan>. This means we're just
+running some tests, don't know how many. [6]
+
+ use Test::More 'no_plan'; # instead of tests => 32
+
+now we can just add tests and not have to do all sorts of math to
+figure out how many we're running.
+
+
+=head2 Informative names
+
+Take a look at this line here
+
+ ok( defined $ical, "new(ical => '$ical_str')" );
+
+we've added more detail about what we're testing and the ICal string
+itself we're trying out to the name. So you get results like:
+
+ ok 25 - new(ical => '19971024T120000')
+ ok 26 - and it's the right class
+ ok 27 - year()
+ ok 28 - month()
+ ok 29 - day()
+ ok 30 - hour()
+ ok 31 - min()
+ ok 32 - sec()
+
+if something in there fails, you'll know which one it was and that
+will make tracking down the problem easier. So try to put a bit of
+debugging information into the test names.
+
+Describe what the tests test, to make debugging a failed test easier
+for you or for the next person who runs your test.
+
+
+=head2 Skipping tests
+
+Poking around in the existing Date::ICal tests, I found this in
+F<t/01sanity.t> [7]
+
+ #!/usr/bin/perl -w
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ # XXX This will only work on unix systems.
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+
+The beginning of the epoch is different on most non-Unix operating
+systems [8]. Even though Perl smooths out the differences for the
+most part, certain ports do it differently. MacPerl is one off the
+top of my head. [9] So rather than just putting a comment in the test,
+we can explicitly say it's never going to work and skip the test.
+
+ use Test::More tests => 7;
+ use Date::ICal;
+
+ # Make sure epoch time is being handled sanely.
+ my $t1 = Date::ICal->new( epoch => 0 );
+ is( $t1->epoch, 0, "Epoch time of 0" );
+
+ SKIP: {
+ skip('epoch to ICal not working on MacOS', 6)
+ if $^O eq 'MacOS';
+
+ is( $t1->ical, '19700101Z', " epoch to ical" );
+
+ is( $t1->year, 1970, " year()" );
+ is( $t1->month, 1, " month()" );
+ is( $t1->day, 1, " day()" );
+
+ # like the tests above, but starting with ical instead of epoch
+ my $t2 = Date::ICal->new( ical => '19700101Z' );
+ is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
+
+ is( $t2->epoch, 0, " and back to ICal" );
+ }
+
+A little bit of magic happens here. When running on anything but
+MacOS, all the tests run normally. But when on MacOS, C<skip()> causes
+the entire contents of the SKIP block to be jumped over. It's never
+run. Instead, it prints special output that tells Test::Harness that
+the tests have been skipped.
+
+ 1..7
+ ok 1 - Epoch time of 0
+ ok 2 # skip epoch to ICal not working on MacOS
+ ok 3 # skip epoch to ICal not working on MacOS
+ ok 4 # skip epoch to ICal not working on MacOS
+ ok 5 # skip epoch to ICal not working on MacOS
+ ok 6 # skip epoch to ICal not working on MacOS
+ ok 7 # skip epoch to ICal not working on MacOS
+
+This means your tests won't fail on MacOS. This means less emails
+from MacPerl users telling you about failing tests that you know will
+never work. You've got to be careful with skip tests. These are for
+tests which don't work and I<never will>. It is not for skipping
+genuine bugs (we'll get to that in a moment).
+
+The tests are wholly and completely skipped. [10] This will work.
+
+ SKIP: {
+ skip("I don't wanna die!");
+
+ die, die, die, die, die;
+ }
+
+
+=head2 Todo tests
+
+Thumbing through the Date::ICal man page, I came across this:
+
+ ical
+
+ $ical_string = $ical->ical;
+
+ Retrieves, or sets, the date on the object, using any
+ valid ICal date/time string.
+
+"Retrieves or sets". Hmmm, didn't see a test for using C<ical()> to set
+the date in the Date::ICal test suite. So I'll write one.
+
+ use Test::More tests => 1;
+ use Date::ICal;
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+
+run that and I get
+
+ 1..1
+ not ok 1 - Setting via ical()
+ # Failed test (- at line 6)
+ # got: '20010814T233649Z'
+ # expected: '20201231Z'
+ # Looks like you failed 1 tests of 1.
+
+Whoops! Looks like it's unimplemented. Let's assume we don't have
+the time to fix this. [11] Normally, you'd just comment out the test
+and put a note in a todo list somewhere. Instead, we're going to
+explicitly state "this test will fail" by wrapping it in a C<TODO> block.
+
+ use Test::More tests => 1;
+
+ TODO: {
+ local $TODO = 'ical($ical) not yet implemented';
+
+ my $ical = Date::ICal->new;
+ $ical->ical('20201231Z');
+
+ is( $ical->ical, '20201231Z', 'Setting via ical()' );
+ }
+
+Now when you run, it's a little different:
+
+ 1..1
+ not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented
+ # got: '20010822T201551Z'
+ # expected: '20201231Z'
+
+Test::More doesn't say "Looks like you failed 1 tests of 1". That '#
+TODO' tells Test::Harness "this is supposed to fail" and it treats a
+failure as a successful test. So you can write tests even before
+you've fixed the underlying code.
+
+If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY
+SUCCEEDED". When that happens, you simply remove the TODO block with
+C<local $TODO> and turn it into a real test.
+
+
+=head2 Testing with taint mode.
+
+Taint mode is a funny thing. It's the globalest of all global
+features. Once you turn it on, it affects I<all> code in your program
+and I<all> modules used (and all the modules they use). If a single
+piece of code isn't taint clean, the whole thing explodes. With that
+in mind, it's very important to ensure your module works under taint
+mode.
+
+It's very simple to have your tests run under taint mode. Just throw
+a C<-T> into the C<#!> line. Test::Harness will read the switches
+in C<#!> and use them to run your tests.
+
+ #!/usr/bin/perl -Tw
+
+ ...test normally here...
+
+So when you say C<make test> it will be run with taint mode and
+warnings on.
+
+
+=head1 FOOTNOTES
+
+=over 4
+
+=item 1
+
+The first number doesn't really mean anything, but it has to be 1.
+It's the second number that's important.
+
+=item 2
+
+For those following along at home, I'm using version 1.31. It has
+some bugs, which is good -- we'll uncover them with our tests.
+
+=item 3
+
+You can actually take this one step further and test the manual
+itself. Have a look at B<Test::Inline> (formerly B<Pod::Tests>).
+
+=item 4
+
+Yes, there's a mistake in the test suite. What! Me, contrived?
+
+=item 5
+
+We'll get to testing the contents of lists later.
+
+=item 6
+
+But what happens if your test program dies halfway through?! Since we
+didn't say how many tests we're going to run, how can we know it
+failed? No problem, Test::More employs some magic to catch that death
+and turn the test into a failure, even if every test passed up to that
+point.
+
+=item 7
+
+I cleaned it up a little.
+
+=item 8
+
+Most Operating Systems record time as the number of seconds since a
+certain date. This date is the beginning of the epoch. Unix's starts
+at midnight January 1st, 1970 GMT.
+
+=item 9
+
+MacOS's epoch is midnight January 1st, 1904. VMS's is midnight,
+November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a
+problem.
+
+=item 10
+
+As long as the code inside the SKIP block at least compiles. Please
+don't ask how. No, it's not a filter.
+
+=item 11
+
+Do NOT be tempted to use TODO tests as a way to avoid fixing simple
+bugs!
+
+=back
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers!
+
+=head1 COPYRIGHT
+
+Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This documentation is free; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+Irrespective of its distribution, all code examples in these files
+are hereby placed into the public domain. You are permitted and
+encouraged to use this code in your own programs for fun
+or for profit as you see fit. A simple comment in the code giving
+credit would be courteous but is not required.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Text/Abbrev.pm b/Master/tlpkg/tlperl/lib/Text/Abbrev.pm
new file mode 100644
index 00000000000..c6be63bcc60
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/Abbrev.pm
@@ -0,0 +1,84 @@
+package Text::Abbrev;
+require 5.005; # Probably works on earlier versions too.
+require Exporter;
+
+our $VERSION = '1.01';
+
+=head1 NAME
+
+abbrev - create an abbreviation table from a list
+
+=head1 SYNOPSIS
+
+ use Text::Abbrev;
+ abbrev $hashref, LIST
+
+
+=head1 DESCRIPTION
+
+Stores all unambiguous truncations of each element of LIST
+as keys in the associative array referenced by C<$hashref>.
+The values are the original list elements.
+
+=head1 EXAMPLE
+
+ $hashref = abbrev qw(list edit send abort gripe);
+
+ %hash = abbrev qw(list edit send abort gripe);
+
+ abbrev $hashref, qw(list edit send abort gripe);
+
+ abbrev(*hash, qw(list edit send abort gripe));
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(abbrev);
+
+# Usage:
+# abbrev \%foo, LIST;
+# ...
+# $long = $foo{$short};
+
+sub abbrev {
+ my ($word, $hashref, $glob, %table, $returnvoid);
+
+ @_ or return; # So we don't autovivify onto @_ and trigger warning
+ if (ref($_[0])) { # hash reference preferably
+ $hashref = shift;
+ $returnvoid = 1;
+ } elsif (ref \$_[0] eq 'GLOB') { # is actually a glob (deprecated)
+ $hashref = \%{shift()};
+ $returnvoid = 1;
+ }
+ %{$hashref} = ();
+
+ WORD: foreach $word (@_) {
+ for (my $len = (length $word) - 1; $len > 0; --$len) {
+ my $abbrev = substr($word,0,$len);
+ my $seen = ++$table{$abbrev};
+ if ($seen == 1) { # We're the first word so far to have
+ # this abbreviation.
+ $hashref->{$abbrev} = $word;
+ } elsif ($seen == 2) { # We're the second word to have this
+ # abbreviation, so we can't use it.
+ delete $hashref->{$abbrev};
+ } else { # We're the third word to have this
+ # abbreviation, so skip to the next word.
+ next WORD;
+ }
+ }
+ }
+ # Non-abbreviations always get entered, even if they aren't unique
+ foreach $word (@_) {
+ $hashref->{$word} = $word;
+ }
+ return if $returnvoid;
+ if (wantarray) {
+ %{$hashref};
+ } else {
+ $hashref;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Text/Balanced.pm b/Master/tlpkg/tlperl/lib/Text/Balanced.pm
new file mode 100644
index 00000000000..07d956735c2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/Balanced.pm
@@ -0,0 +1,2281 @@
+package Text::Balanced;
+
+# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS.
+# FOR FULL DOCUMENTATION SEE Balanced.pod
+
+use 5.005;
+use strict;
+use Exporter ();
+use SelfLoader;
+
+use vars qw { $VERSION @ISA %EXPORT_TAGS };
+BEGIN {
+ $VERSION = '2.02';
+ @ISA = '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("..",@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__
+
+=pod
+
+=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@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 1997 - 2001 Damian Conway. All Rights Reserved.
+
+Some (minor) parts copyright 2009 Adam Kennedy.
+
+This module is free software. It may be used, redistributed
+and/or modified under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Text/ParseWords.pm b/Master/tlpkg/tlperl/lib/Text/ParseWords.pm
new file mode 100644
index 00000000000..f1b5937904e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/ParseWords.pm
@@ -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 &quotewords() 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. &quotewords()
+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.,
+&quotewords() 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 &quotewords(), 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@netcom.com>, 1994-1997 (Original
+author unknown). Much of the code for &parse_line() (including the
+primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>.
+
+Examples section another documentation provided by John Heidemann
+<johnh@ISI.EDU>
+
+Bug reports, patches, and nagging provided by lots of folks-- thanks
+everybody! Special thanks to Michael Schwern <schwern@envirolink.org>
+for assuring me that a &nested_quotewords() would be useful, and to
+Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about
+error-checking (sort of-- you had to be there).
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Text/Soundex.pm b/Master/tlpkg/tlperl/lib/Text/Soundex.pm
new file mode 100644
index 00000000000..598b8a8fe94
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/Soundex.pm
@@ -0,0 +1,260 @@
+# -*- perl -*-
+
+# (c) Copyright 1998-2007 by Mark Mielke
+#
+# Freedom to use these sources for whatever you want, as long as credit
+# is given where credit is due, is hereby granted. You may make modifications
+# where you see fit but leave this copyright somewhere visible. As well, try
+# to initial any changes you make so that if I like the changes I can
+# incorporate them into later versions.
+#
+# - Mark Mielke <mark@mielke.cc>
+#
+
+package Text::Soundex;
+require 5.006;
+
+use Exporter ();
+use XSLoader ();
+
+use strict;
+
+our $VERSION = '3.03_01';
+our @EXPORT_OK = qw(soundex soundex_unicode soundex_nara soundex_nara_unicode
+ $soundex_nocode);
+our @EXPORT = qw(soundex soundex_nara $soundex_nocode);
+our @ISA = qw(Exporter);
+
+our $nocode;
+
+# Previous releases of Text::Soundex made $nocode available as $soundex_nocode.
+# For now, this part of the interface is exported and maintained.
+# In the feature, $soundex_nocode will be deprecated.
+*Text::Soundex::soundex_nocode = \$nocode;
+
+sub soundex_noxs
+{
+ # Original Soundex algorithm
+
+ my @results = map {
+ my $code = uc($_);
+ $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd;
+
+ if (length($code)) {
+ my $firstchar = substr($code, 0, 1);
+ $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr]
+ [0000000000000000111111112222222222222222333344555566]s;
+ ($code = substr($code, 1)) =~ tr/0//d;
+ substr($firstchar . $code . '000', 0, 4);
+ } else {
+ $nocode;
+ }
+ } @_;
+
+ wantarray ? @results : $results[0];
+}
+
+sub soundex_nara
+{
+ # US census (NARA) algorithm.
+
+ my @results = map {
+ my $code = uc($_);
+ $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd;
+
+ if (length($code)) {
+ my $firstchar = substr($code, 0, 1);
+ $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr]
+ [0000990000009900111111112222222222222222333344555566]s;
+ $code =~ s/(.)9\1/$1/gs;
+ ($code = substr($code, 1)) =~ tr/09//d;
+ substr($firstchar . $code . '000', 0, 4);
+ } else {
+ $nocode
+ }
+ } @_;
+
+ wantarray ? @results : $results[0];
+}
+
+sub soundex_unicode
+{
+ require Text::Unidecode unless defined &Text::Unidecode::unidecode;
+ soundex(Text::Unidecode::unidecode(@_));
+}
+
+sub soundex_nara_unicode
+{
+ require Text::Unidecode unless defined &Text::Unidecode::unidecode;
+ soundex_nara(Text::Unidecode::unidecode(@_));
+}
+
+eval { XSLoader::load(__PACKAGE__, $VERSION) };
+
+if (defined(&soundex_xs)) {
+ *soundex = \&soundex_xs;
+} else {
+ *soundex = \&soundex_noxs;
+ *soundex_xs = sub {
+ require Carp;
+ Carp::croak("XS implementation of Text::Soundex::soundex_xs() ".
+ "could not be loaded");
+ };
+}
+
+1;
+
+__END__
+
+# Implementation of the soundex algorithm.
+#
+# Some of this documention was written by Mike Stok.
+#
+# Examples:
+#
+# Euler, Ellery -> E460
+# Gauss, Ghosh -> G200
+# Hilbert, Heilbronn -> H416
+# Knuth, Kant -> K530
+# Lloyd, Ladd -> L300
+# Lukasiewicz, Lissajous -> L222
+#
+
+=head1 NAME
+
+Text::Soundex - Implementation of the soundex algorithm.
+
+=head1 SYNOPSIS
+
+ use Text::Soundex;
+
+ # Original algorithm.
+ $code = soundex($name); # Get the soundex code for a name.
+ @codes = soundex(@names); # Get the list of codes for a list of names.
+
+ # American Soundex variant (NARA) - Used for US census data.
+ $code = soundex_nara($name); # Get the soundex code for a name.
+ @codes = soundex_nara(@names); # Get the list of codes for a list of names.
+
+ # Redefine the value that soundex() will return if the input string
+ # contains no identifiable sounds within it.
+ $Text::Soundex::nocode = 'Z000';
+
+=head1 DESCRIPTION
+
+Soundex is a phonetic algorithm for indexing names by sound, as
+pronounced in English. The goal is for names with the same
+pronunciation to be encoded to the same representation so that they
+can be matched despite minor differences in spelling. Soundex is the
+most widely known of all phonetic algorithms and is often used
+(incorrectly) as a synonym for "phonetic algorithm". Improvements to
+Soundex are the basis for many modern phonetic algorithms. (Wikipedia,
+2007)
+
+This module implements the original soundex algorithm developed by
+Robert Russell and Margaret Odell, patented in 1918 and 1922, as well
+as a variation called "American Soundex" used for US census data, and
+current maintained by the National Archives and Records Administration
+(NARA).
+
+The soundex algorithm may be recognized from Donald Knuth's
+B<The Art of Computer Programming>. The algorithm described by
+Knuth is the NARA algorithm.
+
+The value returned for strings which have no soundex encoding is
+defined using C<$Text::Soundex::nocode>. The default value is C<undef>,
+however values such as C<'Z000'> are commonly used alternatives.
+
+For backward compatibility with older versions of this module the
+C<$Text::Soundex::nocode> is exported into the caller's namespace as
+C<$soundex_nocode>.
+
+In scalar context, C<soundex()> returns the soundex code of its first
+argument. In list context, a list is returned in which each element is the
+soundex code for the corresponding argument passed to C<soundex()>. For
+example, the following code assigns @codes the value C<('M200', 'S320')>:
+
+ @codes = soundex qw(Mike Stok);
+
+To use C<Text::Soundex> to generate codes that can be used to search one
+of the publically available US Censuses, a variant of the soundex
+algorithm must be used:
+
+ use Text::Soundex;
+ $code = soundex_nara($name);
+
+An example of where these algorithm differ follows:
+
+ use Text::Soundex;
+ print soundex("Ashcraft"), "\n"; # prints: A226
+ print soundex_nara("Ashcraft"), "\n"; # prints: A261
+
+=head1 EXAMPLES
+
+Donald Knuth's examples of names and the soundex codes they map to
+are listed below:
+
+ Euler, Ellery -> E460
+ Gauss, Ghosh -> G200
+ Hilbert, Heilbronn -> H416
+ Knuth, Kant -> K530
+ Lloyd, Ladd -> L300
+ Lukasiewicz, Lissajous -> L222
+
+so:
+
+ $code = soundex 'Knuth'; # $code contains 'K530'
+ @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200'
+
+=head1 LIMITATIONS
+
+As the soundex algorithm was originally used a B<long> time ago in the US
+it considers only the English alphabet and pronunciation. In particular,
+non-ASCII characters will be ignored. The recommended method of dealing
+with characters that have accents, or other unicode characters, is to use
+the Text::Unidecode module available from CPAN. Either use the module
+explicitly:
+
+ use Text::Soundex;
+ use Text::Unidecode;
+
+ print soundex(unidecode("Fran\xE7ais")), "\n"; # Prints "F652\n"
+
+Or use the convenient wrapper routine:
+
+ use Text::Soundex 'soundex_unicode';
+
+ print soundex_unicode("Fran\xE7ais"), "\n"; # Prints "F652\n"
+
+Since the soundex algorithm maps a large space (strings of arbitrary
+length) onto a small space (single letter plus 3 digits) no inference
+can be made about the similarity of two strings which end up with the
+same soundex code. For example, both C<Hilbert> and C<Heilbronn> end
+up with a soundex code of C<H416>.
+
+=head1 MAINTAINER
+
+This module is currently maintain by Mark Mielke (C<mark@mielke.cc>).
+
+=head1 HISTORY
+
+Version 3 is a significant update to provide support for versions of
+Perl later than Perl 5.004. Specifically, the XS version of the
+soundex() subroutine understands strings that are encoded using UTF-8
+(unicode strings).
+
+Version 2 of this module was a re-write by Mark Mielke (C<mark@mielke.cc>)
+to improve the speed of the subroutines. The XS version of the soundex()
+subroutine was introduced in 2.00.
+
+Version 1 of this module was written by Mike Stok (C<mike@stok.co.uk>)
+and was included into the Perl core library set.
+
+Dave Carlsen (C<dcarlsen@csranet.com>) made the request for the NARA
+algorithm to be included. The NARA soundex page can be viewed at:
+C<http://www.nara.gov/genealogy/soundex/soundex.html>
+
+Ian Phillips (C<ian@pipex.net>) and Rich Pinder (C<rpinder@hsc.usc.edu>)
+supplied ideas and spotted mistakes for v1.x.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Text/Tabs.pm b/Master/tlpkg/tlperl/lib/Text/Tabs.pm
new file mode 100644
index 00000000000..d3c06a08c10
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/Tabs.pm
@@ -0,0 +1,136 @@
+
+package Text::Tabs;
+
+require Exporter;
+
+@ISA = (Exporter);
+@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('',@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.
+
diff --git a/Master/tlpkg/tlperl/lib/Text/Wrap.pm b/Master/tlpkg/tlperl/lib/Text/Wrap.pm
new file mode 100644
index 00000000000..de8620247f2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Text/Wrap.pm
@@ -0,0 +1,265 @@
+package Text::Wrap;
+
+use warnings::register;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(wrap fill);
+@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",@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@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.
+
diff --git a/Master/tlpkg/tlperl/lib/Thread/Queue.pm b/Master/tlpkg/tlperl/lib/Thread/Queue.pm
new file mode 100644
index 00000000000..631edf126a6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Thread/Queue.pm
@@ -0,0 +1,481 @@
+package Thread::Queue;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.11';
+
+use threads::shared 1.21;
+use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr);
+
+# Carp errors from threads::shared calls should complain about caller
+our @CARP_NOT = ("threads::shared");
+
+# Predeclarations for internal functions
+my ($validate_count, $validate_index);
+
+# Create a new queue possibly pre-populated with items
+sub new
+{
+ my $class = shift;
+ my @queue :shared = map { shared_clone($_) } @_;
+ return bless(\@queue, $class);
+}
+
+# Add items to the tail of a queue
+sub enqueue
+{
+ my $queue = shift;
+ lock(@$queue);
+ push(@$queue, map { shared_clone($_) } @_)
+ and cond_signal(@$queue);
+}
+
+# Return a count of the number of items on a queue
+sub pending
+{
+ my $queue = shift;
+ lock(@$queue);
+ return scalar(@$queue);
+}
+
+# Return 1 or more items from the head of a queue, blocking if needed
+sub dequeue
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Wait for requisite number of items
+ cond_wait(@$queue) until (@$queue >= $count);
+ cond_signal(@$queue) if (@$queue > $count);
+
+ # Return single item
+ return shift(@$queue) if ($count == 1);
+
+ # Return multiple items
+ my @items;
+ push(@items, shift(@$queue)) for (1..$count);
+ return @items;
+}
+
+# Return items from the head of a queue with no blocking
+sub dequeue_nb
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Return single item
+ return shift(@$queue) if ($count == 1);
+
+ # Return multiple items
+ my @items;
+ for (1..$count) {
+ last if (! @$queue);
+ push(@items, shift(@$queue));
+ }
+ return @items;
+}
+
+# Return an item without removing it from a queue
+sub peek
+{
+ my $queue = shift;
+ lock(@$queue);
+ my $index = @_ ? $validate_index->(shift) : 0;
+ return $$queue[$index];
+}
+
+# Insert items anywhere into a queue
+sub insert
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $index = $validate_index->(shift);
+
+ return if (! @_); # Nothing to insert
+
+ # Support negative indices
+ if ($index < 0) {
+ $index += @$queue;
+ if ($index < 0) {
+ $index = 0;
+ }
+ }
+
+ # Dequeue items from $index onward
+ my @tmp;
+ while (@$queue > $index) {
+ unshift(@tmp, pop(@$queue))
+ }
+
+ # Add new items to the queue
+ push(@$queue, map { shared_clone($_) } @_);
+
+ # Add previous items back onto the queue
+ push(@$queue, @tmp);
+
+ # Soup's up
+ cond_signal(@$queue);
+}
+
+# Remove items from anywhere in a queue
+sub extract
+{
+ my $queue = shift;
+ lock(@$queue);
+
+ my $index = @_ ? $validate_index->(shift) : 0;
+ my $count = @_ ? $validate_count->(shift) : 1;
+
+ # Support negative indices
+ if ($index < 0) {
+ $index += @$queue;
+ if ($index < 0) {
+ $count += $index;
+ return if ($count <= 0); # Beyond the head of the queue
+ return $queue->dequeue_nb($count); # Extract from the head
+ }
+ }
+
+ # Dequeue items from $index+$count onward
+ my @tmp;
+ while (@$queue > ($index+$count)) {
+ unshift(@tmp, pop(@$queue))
+ }
+
+ # Extract desired items
+ my @items;
+ unshift(@items, pop(@$queue)) while (@$queue > $index);
+
+ # Add back any removed items
+ push(@$queue, @tmp);
+
+ # Return single item
+ return $items[0] if ($count == 1);
+
+ # Return multiple items
+ return @items;
+}
+
+### Internal Functions ###
+
+# Check value of the requested index
+$validate_index = sub {
+ my $index = shift;
+
+ if (! defined($index) ||
+ ! looks_like_number($index) ||
+ (int($index) != $index))
+ {
+ require Carp;
+ my ($method) = (caller(1))[3];
+ $method =~ s/Thread::Queue:://;
+ $index = 'undef' if (! defined($index));
+ Carp::croak("Invalid 'index' argument ($index) to '$method' method");
+ }
+
+ return $index;
+};
+
+# Check value of the requested count
+$validate_count = sub {
+ my $count = shift;
+
+ if (! defined($count) ||
+ ! looks_like_number($count) ||
+ (int($count) != $count) ||
+ ($count < 1))
+ {
+ require Carp;
+ my ($method) = (caller(1))[3];
+ $method =~ s/Thread::Queue:://;
+ $count = 'undef' if (! defined($count));
+ Carp::croak("Invalid 'count' argument ($count) to '$method' method");
+ }
+
+ return $count;
+};
+
+1;
+
+=head1 NAME
+
+Thread::Queue - Thread-safe queues
+
+=head1 VERSION
+
+This document describes Thread::Queue version 2.11
+
+=head1 SYNOPSIS
+
+ use strict;
+ use warnings;
+
+ use threads;
+ use Thread::Queue;
+
+ my $q = Thread::Queue->new(); # A new empty queue
+
+ # Worker thread
+ my $thr = threads->create(sub {
+ while (my $item = $q->dequeue()) {
+ # Do work on $item
+ }
+ })->detach();
+
+ # Send work to the thread
+ $q->enqueue($item1, ...);
+
+
+ # Count of items in the queue
+ my $left = $q->pending();
+
+ # Non-blocking dequeue
+ if (defined(my $item = $q->dequeue_nb())) {
+ # Work on $item
+ }
+
+ # Get the second item in the queue without dequeuing anything
+ my $item = $q->peek(1);
+
+ # Insert two items into the queue just behind the head
+ $q->insert(1, $item1, $item2);
+
+ # Extract the last two items on the queue
+ my ($item1, $item2) = $q->extract(-2, 2);
+
+=head1 DESCRIPTION
+
+This module provides thread-safe FIFO queues that can be accessed safely by
+any number of threads.
+
+Any data types supported by L<threads::shared> can be passed via queues:
+
+=over
+
+=item Ordinary scalars
+
+=item Array refs
+
+=item Hash refs
+
+=item Scalar refs
+
+=item Objects based on the above
+
+=back
+
+Ordinary scalars are added to queues as they are.
+
+If not already thread-shared, the other complex data types will be cloned
+(recursively, if needed, and including any C<bless>ings and read-only
+settings) into thread-shared structures before being placed onto a queue.
+
+For example, the following would cause L<Thread::Queue> to create a empty,
+shared array reference via C<&shared([])>, copy the elements 'foo', 'bar'
+and 'baz' from C<@ary> into it, and then place that shared reference onto
+the queue:
+
+ my @ary = qw/foo bar baz/;
+ $q->enqueue(\@ary);
+
+However, for the following, the items are already shared, so their references
+are added directly to the queue, and no cloning takes place:
+
+ my @ary :shared = qw/foo bar baz/;
+ $q->enqueue(\@ary);
+
+ my $obj = &shared({});
+ $$obj{'foo'} = 'bar';
+ $$obj{'qux'} = 99;
+ bless($obj, 'My::Class');
+ $q->enqueue($obj);
+
+See L</"LIMITATIONS"> for caveats related to passing objects via queues.
+
+=head1 QUEUE CREATION
+
+=over
+
+=item ->new()
+
+Creates a new empty queue.
+
+=item ->new(LIST)
+
+Creates a new queue pre-populated with the provided list of items.
+
+=back
+
+=head1 BASIC METHODS
+
+The following methods deal with queues on a FIFO basis.
+
+=over
+
+=item ->enqueue(LIST)
+
+Adds a list of items onto the end of the queue.
+
+=item ->dequeue()
+
+=item ->dequeue(COUNT)
+
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them. If the queue contains fewer than the requested
+number of items, then the thread will be blocked until the requisite number
+of items are available (i.e., until other threads <enqueue> more items).
+
+=item ->dequeue_nb()
+
+=item ->dequeue_nb(COUNT)
+
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them. If the queue contains fewer than the requested
+number of items, then it immediately (i.e., non-blocking) returns whatever
+items there are on the queue. If the queue is empty, then C<undef> is
+returned.
+
+=item ->pending()
+
+Returns the number of items still in the queue.
+
+=back
+
+=head1 ADVANCED METHODS
+
+The following methods can be used to manipulate items anywhere in a queue.
+
+To prevent the contents of a queue from being modified by another thread
+while it is being examined and/or changed, L<lock|threads::shared/"lock
+VARIABLE"> the queue inside a local block:
+
+ {
+ lock($q); # Keep other threads from changing the queue's contents
+ my $item = $q->peek();
+ if ($item ...) {
+ ...
+ }
+ }
+ # Queue is now unlocked
+
+=over
+
+=item ->peek()
+
+=item ->peek(INDEX)
+
+Returns an item from the queue without dequeuing anything. Defaults to the
+the head of queue (at index position 0) if no index is specified. Negative
+index values are supported as with L<arrays|perldata/"Subscripts"> (i.e., -1
+is the end of the queue, -2 is next to last, and so on).
+
+If no items exists at the specified index (i.e., the queue is empty, or the
+index is beyond the number of items on the queue), then C<undef> is returned.
+
+Remember, the returned item is not removed from the queue, so manipulating a
+C<peek>ed at reference affects the item on the queue.
+
+=item ->insert(INDEX, LIST)
+
+Adds the list of items to the queue at the specified index position (0
+is the head of the list). Any existing items at and beyond that position are
+pushed back past the newly added items:
+
+ $q->enqueue(1, 2, 3, 4);
+ $q->insert(1, qw/foo bar/);
+ # Queue now contains: 1, foo, bar, 2, 3, 4
+
+Specifying an index position greater than the number of items in the queue
+just adds the list to the end.
+
+Negative index positions are supported:
+
+ $q->enqueue(1, 2, 3, 4);
+ $q->insert(-2, qw/foo bar/);
+ # Queue now contains: 1, 2, foo, bar, 3, 4
+
+Specifying a negative index position greater than the number of items in the
+queue adds the list to the head of the queue.
+
+=item ->extract()
+
+=item ->extract(INDEX)
+
+=item ->extract(INDEX, COUNT)
+
+Removes and returns the specified number of items (defaults to 1) from the
+specified index position in the queue (0 is the head of the queue). When
+called with no arguments, C<extract> operates the same as C<dequeue_nb>.
+
+This method is non-blocking, and will return only as many items as are
+available to fulfill the request:
+
+ $q->enqueue(1, 2, 3, 4);
+ my $item = $q->extract(2) # Returns 3
+ # Queue now contains: 1, 2, 4
+ my @items = $q->extract(1, 3) # Returns (2, 4)
+ # Queue now contains: 1
+
+Specifying an index position greater than the number of items in the
+queue results in C<undef> or an empty list being returned.
+
+ $q->enqueue('foo');
+ my $nada = $q->extract(3) # Returns undef
+ my @nada = $q->extract(1, 3) # Returns ()
+
+Negative index positions are supported. Specifying a negative index position
+greater than the number of items in the queue may return items from the head
+of the queue (similar to C<dequeue_nb>) if the count overlaps the head of the
+queue from the specified position (i.e. if queue size + index + count is
+greater than zero):
+
+ $q->enqueue(qw/foo bar baz/);
+ my @nada = $q->extract(-6, 2); # Returns () - (3+(-6)+2) <= 0
+ my @some = $q->extract(-6, 4); # Returns (foo) - (3+(-6)+4) > 0
+ # Queue now contains: bar, baz
+ my @rest = $q->extract(-3, 4); # Returns (bar, baz) - (2+(-3)+4) > 0
+
+=back
+
+=head1 NOTES
+
+Queues created by L<Thread::Queue> can be used in both threaded and
+non-threaded applications.
+
+=head1 LIMITATIONS
+
+Passing objects on queues may not work if the objects' classes do not support
+sharing. See L<threads::shared/"BUGS AND LIMITATIONS"> for more.
+
+Passing array/hash refs that contain objects may not work for Perl prior to
+5.10.0.
+
+=head1 SEE ALSO
+
+Thread::Queue Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Queue>
+
+Annotated POD for Thread::Queue:
+L<http://annocpan.org/~JDHEDDEN/Thread-Queue-2.11/lib/Thread/Queue.pm>
+
+Source repository:
+L<http://code.google.com/p/thread-queue/>
+
+L<threads>, L<threads::shared>
+
+=head1 MAINTAINER
+
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Thread/Semaphore.pm b/Master/tlpkg/tlperl/lib/Thread/Semaphore.pm
new file mode 100644
index 00000000000..67cb30e66a6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Thread/Semaphore.pm
@@ -0,0 +1,170 @@
+package Thread::Semaphore;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.09';
+
+use threads::shared;
+use Scalar::Util 1.10 qw(looks_like_number);
+
+# Create a new semaphore optionally with specified count (count defaults to 1)
+sub new {
+ my $class = shift;
+ my $val :shared = @_ ? shift : 1;
+ if (!defined($val) ||
+ ! looks_like_number($val) ||
+ (int($val) != $val))
+ {
+ require Carp;
+ $val = 'undef' if (! defined($val));
+ Carp::croak("Semaphore initializer is not an integer: $val");
+ }
+ return bless(\$val, $class);
+}
+
+# Decrement a semaphore's count (decrement amount defaults to 1)
+sub down {
+ my $sema = shift;
+ lock($$sema);
+ my $dec = @_ ? shift : 1;
+ if (! defined($dec) ||
+ ! looks_like_number($dec) ||
+ (int($dec) != $dec) ||
+ ($dec < 1))
+ {
+ require Carp;
+ $dec = 'undef' if (! defined($dec));
+ Carp::croak("Semaphore decrement is not a positive integer: $dec");
+ }
+ cond_wait($$sema) until ($$sema >= $dec);
+ $$sema -= $dec;
+}
+
+# Increment a semaphore's count (increment amount defaults to 1)
+sub up {
+ my $sema = shift;
+ lock($$sema);
+ my $inc = @_ ? shift : 1;
+ if (! defined($inc) ||
+ ! looks_like_number($inc) ||
+ (int($inc) != $inc) ||
+ ($inc < 1))
+ {
+ require Carp;
+ $inc = 'undef' if (! defined($inc));
+ Carp::croak("Semaphore increment is not a positive integer: $inc");
+ }
+ ($$sema += $inc) > 0 and cond_broadcast($$sema);
+}
+
+1;
+
+=head1 NAME
+
+Thread::Semaphore - Thread-safe semaphores
+
+=head1 VERSION
+
+This document describes Thread::Semaphore version 2.09
+
+=head1 SYNOPSIS
+
+ use Thread::Semaphore;
+ my $s = Thread::Semaphore->new();
+ $s->down(); # Also known as the semaphore P operation.
+ # The guarded section is here
+ $s->up(); # Also known as the semaphore V operation.
+
+ # The default semaphore value is 1
+ my $s = Thread::Semaphore-new($initial_value);
+ $s->down($down_value);
+ $s->up($up_value);
+
+=head1 DESCRIPTION
+
+Semaphores provide a mechanism to regulate access to resources. Unlike
+locks, semaphores aren't tied to particular scalars, and so may be used to
+control access to anything you care to use them for.
+
+Semaphores don't limit their values to zero and one, so they can be used to
+control access to some resource that there may be more than one of (e.g.,
+filehandles). Increment and decrement amounts aren't fixed at one either,
+so threads can reserve or return multiple resources at once.
+
+=head1 METHODS
+
+=over 8
+
+=item ->new()
+
+=item ->new(NUMBER)
+
+C<new> creates a new semaphore, and initializes its count to the specified
+number (which must be an integer). If no number is specified, the
+semaphore's count defaults to 1.
+
+=item ->down()
+
+=item ->down(NUMBER)
+
+The C<down> method decreases the semaphore's count by the specified number
+(which must be an integer >= 1), or by one if no number is specified.
+
+If the semaphore's count would drop below zero, this method will block
+until such time as the semaphore's count is greater than or equal to the
+amount you're C<down>ing the semaphore's count by.
+
+This is the semaphore "P operation" (the name derives from the Dutch
+word "pak", which means "capture" -- the semaphore operations were
+named by the late Dijkstra, who was Dutch).
+
+=item ->up()
+
+=item ->up(NUMBER)
+
+The C<up> method increases the semaphore's count by the number specified
+(which must be an integer >= 1), or by one if no number is specified.
+
+This will unblock any thread that is blocked trying to C<down> the
+semaphore if the C<up> raises the semaphore's count above the amount that
+the C<down> is trying to decrement it by. For example, if three threads
+are blocked trying to C<down> a semaphore by one, and another thread C<up>s
+the semaphore by two, then two of the blocked threads (which two is
+indeterminate) will become unblocked.
+
+This is the semaphore "V operation" (the name derives from the Dutch
+word "vrij", which means "release").
+
+=back
+
+=head1 NOTES
+
+Semaphores created by L<Thread::Semaphore> can be used in both threaded and
+non-threaded applications. This allows you to write modules and packages
+that potentially make use of semaphores, and that will function in either
+environment.
+
+=head1 SEE ALSO
+
+Thread::Semaphore Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Semaphore>
+
+Annotated POD for Thread::Semaphore:
+L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.09/lib/Thread/Semaphore.pm>
+
+Source repository:
+L<http://code.google.com/p/thread-semaphore/>
+
+L<threads>, L<threads::shared>
+
+=head1 MAINTAINER
+
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tie/Array.pm b/Master/tlpkg/tlperl/lib/Tie/Array.pm
new file mode 100644
index 00000000000..af8f51e9f51
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Array.pm
@@ -0,0 +1,287 @@
+package Tie::Array;
+
+use 5.006_001;
+use strict;
+use Carp;
+our $VERSION = '1.03';
+
+# Pod documentation after __END__ below.
+
+sub DESTROY { }
+sub EXTEND { }
+sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
+sub SHIFT { shift->SPLICE(0,1) }
+sub CLEAR { shift->STORESIZE(0) }
+
+sub PUSH
+{
+ my $obj = shift;
+ my $i = $obj->FETCHSIZE;
+ $obj->STORE($i++, shift) while (@_);
+}
+
+sub POP
+{
+ my $obj = shift;
+ my $newsize = $obj->FETCHSIZE - 1;
+ my $val;
+ if ($newsize >= 0)
+ {
+ $val = $obj->FETCH($newsize);
+ $obj->STORESIZE($newsize);
+ }
+ $val;
+}
+
+sub SPLICE {
+ my $obj = shift;
+ my $sz = $obj->FETCHSIZE;
+ my $off = (@_) ? shift : 0;
+ $off += $sz if ($off < 0);
+ my $len = (@_) ? shift : $sz - $off;
+ $len += $sz - $off if $len < 0;
+ my @result;
+ for (my $i = 0; $i < $len; $i++) {
+ push(@result,$obj->FETCH($off+$i));
+ }
+ $off = $sz if $off > $sz;
+ $len -= $off + $len - $sz if $off + $len > $sz;
+ if (@_ > $len) {
+ # Move items up to make room
+ my $d = @_ - $len;
+ my $e = $off+$len;
+ $obj->EXTEND($sz+$d);
+ for (my $i=$sz-1; $i >= $e; $i--) {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i+$d,$val);
+ }
+ }
+ elsif (@_ < $len) {
+ # Move items down to close the gap
+ my $d = $len - @_;
+ my $e = $off+$len;
+ for (my $i=$off+$len; $i < $sz; $i++) {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i-$d,$val);
+ }
+ $obj->STORESIZE($sz-$d);
+ }
+ for (my $i=0; $i < @_; $i++) {
+ $obj->STORE($off+$i,$_[$i]);
+ }
+ return wantarray ? @result : pop @result;
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub DELETE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a DELETE method";
+}
+
+package Tie::StdArray;
+use vars qw(@ISA);
+@ISA = 'Tie::Array';
+
+sub TIEARRAY { bless [], $_[0] }
+sub FETCHSIZE { scalar @{$_[0]} }
+sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub CLEAR { @{$_[0]} = () }
+sub POP { pop(@{$_[0]}) }
+sub PUSH { my $o = shift; push(@$o,@_) }
+sub SHIFT { shift(@{$_[0]}) }
+sub UNSHIFT { my $o = shift; unshift(@$o,@_) }
+sub EXISTS { exists $_[0]->[$_[1]] }
+sub DELETE { delete $_[0]->[$_[1]] }
+
+sub SPLICE
+{
+ my $ob = shift;
+ my $sz = $ob->FETCHSIZE;
+ my $off = @_ ? shift : 0;
+ $off += $sz if $off < 0;
+ my $len = @_ ? shift : $sz-$off;
+ return splice(@$ob,$off,$len,@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::Array - base class for tied arrays
+
+=head1 SYNOPSIS
+
+ package Tie::NewArray;
+ use Tie::Array;
+ @ISA = ('Tie::Array');
+
+ # mandatory methods
+ sub TIEARRAY { ... }
+ sub FETCH { ... }
+ sub FETCHSIZE { ... }
+
+ sub STORE { ... } # mandatory if elements writeable
+ sub STORESIZE { ... } # mandatory if elements can be added/deleted
+ sub EXISTS { ... } # mandatory if exists() expected to work
+ sub DELETE { ... } # mandatory if delete() expected to work
+
+ # optional methods - for efficiency
+ sub CLEAR { ... }
+ sub PUSH { ... }
+ sub POP { ... }
+ sub SHIFT { ... }
+ sub UNSHIFT { ... }
+ sub SPLICE { ... }
+ sub EXTEND { ... }
+ sub DESTROY { ... }
+
+ package Tie::NewStdArray;
+ use Tie::Array;
+
+ @ISA = ('Tie::StdArray');
+
+ # all methods provided by default
+
+ package main;
+
+ $object = tie @somearray,Tie::NewArray;
+ $object = tie @somearray,Tie::StdArray;
+ $object = tie @somearray,Tie::NewStdArray;
+
+
+
+=head1 DESCRIPTION
+
+This module provides methods for array-tying classes. See
+L<perltie> for a list of the functions required in order to tie an array
+to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
+and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
+methods that croak() if the delete() or exists() builtins are ever called
+on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
+C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
+C<FETCHSIZE>, C<STORESIZE>.
+
+The B<Tie::StdArray> package provides efficient methods required for tied arrays
+which are implemented as blessed references to an "inner" perl array.
+It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
+like standard arrays, allowing for selective overloading of methods.
+
+For developers wishing to write their own tied arrays, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over 4
+
+=item TIEARRAY classname, LIST
+
+The class method is invoked by the command C<tie @array, classname>. Associates
+an array instance with the specified class. C<LIST> would represent
+additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
+to complete the association. The method should return an object of a class which
+provides the methods below.
+
+=item STORE this, index, value
+
+Store datum I<value> into I<index> for the tied array associated with
+object I<this>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+
+=item FETCH this, index
+
+Retrieve the datum in I<index> for the tied array associated with
+object I<this>.
+
+=item FETCHSIZE this
+
+Returns the total number of items in the tied array associated with
+object I<this>. (Equivalent to C<scalar(@array)>).
+
+=item STORESIZE this, count
+
+Sets the total number of items in the tied array associated with
+object I<this> to be I<count>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+If the array becomes smaller then entries beyond count should be
+deleted.
+
+=item EXTEND this, count
+
+Informative call that array is likely to grow to have I<count> entries.
+Can be used to optimize allocation. This method need do nothing.
+
+=item EXISTS this, key
+
+Verify that the element at index I<key> exists in the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the element at index I<key> from the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item CLEAR this
+
+Clear (remove, delete, ...) all values from the tied array associated with
+object I<this>.
+
+=item DESTROY this
+
+Normal object destructor method.
+
+=item PUSH this, LIST
+
+Append elements of LIST to the array.
+
+=item POP this
+
+Remove last element of the array and return it.
+
+=item SHIFT this
+
+Remove the first element of the array (shifting other elements down)
+and return it.
+
+=item UNSHIFT this, LIST
+
+Insert LIST elements at the beginning of the array, moving existing elements
+up to make room.
+
+=item SPLICE this, offset, length, LIST
+
+Perform the equivalent of C<splice> on the array.
+
+I<offset> is optional and defaults to zero, negative values count back
+from the end of the array.
+
+I<length> is optional and defaults to rest of the array.
+
+I<LIST> may be empty.
+
+Returns a list of the original I<length> elements at I<offset>.
+
+=back
+
+=head1 CAVEATS
+
+There is no support at present for tied @ISA. There is a potential conflict
+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@tiuk.ti.comE<gt>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tie/File.pm b/Master/tlpkg/tlperl/lib/Tie/File.pm
new file mode 100644
index 00000000000..9528ab1bfdb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/File.pm
@@ -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+@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+@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@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
+
diff --git a/Master/tlpkg/tlperl/lib/Tie/Handle.pm b/Master/tlpkg/tlperl/lib/Tie/Handle.pm
new file mode 100644
index 00000000000..4e92f75a3d1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Handle.pm
@@ -0,0 +1,201 @@
+package Tie::Handle;
+
+use 5.006_001;
+our $VERSION = '4.2';
+
+# Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility
+# loading Tie::Handle has to make Tie::StdHandle available.
+use Tie::StdHandle;
+
+=head1 NAME
+
+Tie::Handle - base class definitions for tied handles
+
+=head1 SYNOPSIS
+
+ package NewHandle;
+ require Tie::Handle;
+
+ @ISA = qw(Tie::Handle);
+
+ sub READ { ... } # Provide a needed method
+ sub TIEHANDLE { ... } # Overrides inherited method
+
+
+ package main;
+
+ tie *FH, 'NewHandle';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for handle-tying classes. See
+L<perltie> for a list of the functions required in tying a handle to a package.
+The basic B<Tie::Handle> package provides a C<new> method, as well as methods
+C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>.
+
+For developers wishing to write their own tied-handle classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over 4
+
+=item TIEHANDLE classname, LIST
+
+The method invoked by the command C<tie *glob, classname>. Associates a new
+glob instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item WRITE this, scalar, length, offset
+
+Write I<length> bytes of data from I<scalar> starting at I<offset>.
+
+=item PRINT this, LIST
+
+Print the values in I<LIST>
+
+=item PRINTF this, format, LIST
+
+Print the values in I<LIST> using I<format>
+
+=item READ this, scalar, length, offset
+
+Read I<length> bytes of data into I<scalar> starting at I<offset>.
+
+=item READLINE this
+
+Read a single line
+
+=item GETC this
+
+Get a single character
+
+=item CLOSE this
+
+Close the handle
+
+=item OPEN this, filename
+
+(Re-)open the handle
+
+=item BINMODE this
+
+Specify content is binary
+
+=item EOF this
+
+Test for end of file.
+
+=item TELL this
+
+Return position in the file.
+
+=item SEEK this, offset, whence
+
+Position the file.
+
+Test for end of file.
+
+=item DESTROY this
+
+Free the storage associated with the tied handle referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head1 MORE INFORMATION
+
+The L<perltie> section contains an example of tying handles.
+
+=head1 COMPATIBILITY
+
+This version of Tie::Handle is neither related to nor compatible with
+the Tie::Handle (3.0) module available on CPAN. It was due to an
+accident that two modules with the same name appeared. The namespace
+clash has been cleared in favor of this module that comes with the
+perl core in September 2000 and accordingly the version number has
+been bumped up to 4.0.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHANDLE(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIEHANDLE {
+ my $pkg = shift;
+ if (defined &{"{$pkg}::new"}) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHANDLE method";
+ }
+}
+
+sub PRINT {
+ my $self = shift;
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = join(defined $, ? $, : "",@_);
+ $buf .= $\ if defined $\;
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINT method";
+ }
+}
+
+sub PRINTF {
+ my $self = shift;
+
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = sprintf(shift,@_);
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINTF method";
+ }
+}
+
+sub READLINE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READLINE method";
+}
+
+sub GETC {
+ my $self = shift;
+
+ if($self->can('READ') != \&READ) {
+ my $buf;
+ $self->READ($buf,1);
+ return $buf;
+ }
+ else {
+ croak ref($self)," doesn't define a GETC method";
+ }
+}
+
+sub READ {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READ method";
+}
+
+sub WRITE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a WRITE method";
+}
+
+sub CLOSE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a CLOSE method";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tie/Hash.pm b/Master/tlpkg/tlperl/lib/Tie/Hash.pm
new file mode 100644
index 00000000000..1ca8887e7e3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Hash.pm
@@ -0,0 +1,257 @@
+package Tie::Hash;
+
+our $VERSION = '1.03';
+
+=head1 NAME
+
+Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+ package NewHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::Hash);
+
+ sub DELETE { ... } # Provides needed method
+ sub CLEAR { ... } # Overrides inherited method
+
+
+ package NewStdHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::StdHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0]};
+ # TIEHASH should return a reference to the actual storage
+ sub DELETE { ... }
+
+ package NewExtraHash;
+ require Tie::Hash;
+
+ @ISA = qw(Tie::ExtraHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0][0]};
+ # TIEHASH should return an array reference with the first element being
+ # the reference to the actual storage
+ sub DELETE {
+ $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
+ delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1])
+ }
+
+
+ package main;
+
+ tie %new_hash, 'NewHash';
+ tie %new_std_hash, 'NewStdHash';
+ tie %new_extra_hash, 'NewExtraHash',
+ sub {warn "Doing \U$_[1]\E of $_[2].\n"};
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perltie> for a list of the functions required in order to tie a hash
+to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
+B<Tie::ExtraHash> packages
+provide most methods for hashes described in L<perltie> (the exceptions
+are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
+and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
+C<new> method: it is used if C<TIEHASH> is not defined
+in the case a class forgets to include a C<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over 4
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, classname>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next key in the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+The B<Tie::Hash> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=item SCALAR this
+
+Returns what evaluating the hash in scalar context yields.
+
+B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
+and B<Tie::ExtraHash> do).
+
+=back
+
+=head1 Inheriting from B<Tie::StdHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
+C<TIEHASH> method should return a hash reference, and the remaining methods
+should operate on the hash referenced by the first argument:
+
+ package ReportHash;
+ our @ISA = 'Tie::StdHash';
+
+ sub TIEHASH {
+ my $storage = bless {}, shift;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0]{$_[1]} = $_[2]
+ }
+
+
+=head1 Inheriting from B<Tie::ExtraHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten
+C<TIEHASH> method should return an array reference with the first
+element being a hash reference, and the remaining methods should operate on the
+hash C<< %{ $_[0]->[0] } >>:
+
+ package ReportHash;
+ our @ISA = 'Tie::ExtraHash';
+
+ sub TIEHASH {
+ my $class = shift;
+ my $storage = bless [{}, @_], $class;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage;
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0][0]{$_[1]} = $_[2]
+ }
+
+The default C<TIEHASH> method stores "extra" arguments to tie() starting
+from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
+same storage algorithm as in TIEHASH subroutine above. Hence, a typical
+package inheriting from B<Tie::ExtraHash> does not need to overwrite this
+method.
+
+=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
+
+The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
+B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
+presence of these methods, but if defined, the methods will be called in
+proper time, see L<perltie>.
+
+C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
+
+If needed, these methods should be defined by the package inheriting from
+B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<perltie/"SCALAR">
+to find out what happens when C<SCALAR> does not exist.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implementations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
+good working examples.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHASH(@_);
+}
+
+# Grandfather "new"
+
+sub TIEHASH {
+ my $pkg = shift;
+ if (defined &{"${pkg}::new"}) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHASH method";
+ }
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub CLEAR {
+ my $self = shift;
+ my $key = $self->FIRSTKEY(@_);
+ my @keys;
+
+ while (defined $key) {
+ push @keys, $key;
+ $key = $self->NEXTKEY(@_, $key);
+ }
+ foreach $key (@keys) {
+ $self->DELETE(@_, $key);
+ }
+}
+
+# The Tie::StdHash package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package Tie::StdHash;
+# @ISA = qw(Tie::Hash); # would inherit new() only
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+sub SCALAR { scalar %{$_[0]} }
+
+package Tie::ExtraHash;
+
+sub TIEHASH { my $p = shift; bless [{}, @_], $p }
+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]} }
+sub EXISTS { exists $_[0][0]->{$_[1]} }
+sub DELETE { delete $_[0][0]->{$_[1]} }
+sub CLEAR { %{$_[0][0]} = () }
+sub SCALAR { scalar %{$_[0][0]} }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm b/Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm
new file mode 100644
index 00000000000..58ae743d874
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm
@@ -0,0 +1,62 @@
+package Tie::Hash::NamedCapture;
+
+our $VERSION = "0.06";
+
+# The real meat implemented in XS in universal.c in the core, but this
+# method was left behind because gv.c expects a Purl-Perl method in
+# this package when it loads the tie magic for %+ and %-
+
+my ($one, $all) = Tie::Hash::NamedCapture::flags();
+
+sub TIEHASH {
+ my ($pkg, %arg) = @_;
+ my $flag = $arg{all} ? $all : $one;
+ bless \$flag => $pkg;
+}
+
+tie %+, __PACKAGE__;
+tie %-, __PACKAGE__, all => 1;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::Hash::NamedCapture - Named regexp capture buffers
+
+=head1 SYNOPSIS
+
+ tie my %hash, "Tie::Hash::NamedCapture";
+ # %hash now behaves like %+
+
+ tie my %hash, "Tie::Hash::NamedCapture", all => 1;
+ # %hash now access buffers from regexp in $qr like %-
+
+=head1 DESCRIPTION
+
+This module is used to implement the special hashes C<%+> and C<%->, but it
+can be used to tie other variables as you choose.
+
+When the C<all> parameter is provided, then the tied hash elements will be
+array refs listing the contents of each capture buffer whose name is the
+same as the associated hash key. If none of these buffers were involved in
+the match, the contents of that array ref will be as many C<undef> values
+as there are capture buffers with that name. In other words, the tied hash
+will behave as C<%->.
+
+When the C<all> parameter is omitted or false, then the tied hash elements
+will be the contents of the leftmost defined buffer with the name of the
+associated hash key. In other words, the tied hash will behave as
+C<%+>.
+
+The keys of C<%->-like hashes correspond to all buffer names found in the
+regular expression; the keys of C<%+>-like hashes list only the names of
+buffers that have captured (and that are thus associated to defined values).
+
+=head1 SEE ALSO
+
+L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
+L<perlvar/"%-">.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tie/Memoize.pm b/Master/tlpkg/tlperl/lib/Tie/Memoize.pm
new file mode 100644
index 00000000000..dbe14428280
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Memoize.pm
@@ -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@ilyaz.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tie/RefHash.pm b/Master/tlpkg/tlperl/lib/Tie/RefHash.pm
new file mode 100644
index 00000000000..f95bf41efdf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/RefHash.pm
@@ -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@woobling.orgE<gt>
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+'Nestable' by Ed Avis ed@membled.com
+
+=head1 SEE ALSO
+
+perl(1), perlfunc(1), perltie(1)
+
+=cut
+
+use Tie::Hash;
+use vars '@ISA';
+@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';
+@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;
diff --git a/Master/tlpkg/tlperl/lib/Tie/Registry.pm b/Master/tlpkg/tlperl/lib/Tie/Registry.pm
new file mode 100644
index 00000000000..2ded338d342
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Registry.pm
@@ -0,0 +1,45 @@
+package Tie::Registry;
+
+# Tie/Registry.pm -- Provides backward compatibility for Win32::TieRegistry
+# that was called Tie::Registry prior to version 0.20.
+# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
+
+use strict;
+use Carp;
+
+use vars qw( $VERSION @ISA );
+BEGIN {
+ require Win32::TieRegistry;
+ $VERSION = '0.15';
+ @ISA = qw{Win32::TieRegistry};
+}
+
+sub import {
+ my $pkg = shift;
+ Win32::TieRegistry->import( ExportLevel => 1, SplitMultis => 0, @_ );
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Tie::Registry - Legacy interface to Win32::TieRegistry (DEPRECATED)
+
+=head1 DESCRIPTION
+
+This module provides backward compatibility for L<Win32::TieRegistry>
+that was called Tie::Registry prior to version 0.20.
+
+=head1 AUTHOR
+
+Tye McQueen E<lt>tye@metronet.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 1999 Tye McQueen.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tie/Scalar.pm b/Master/tlpkg/tlperl/lib/Tie/Scalar.pm
new file mode 100644
index 00000000000..24e4ae79c3c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Scalar.pm
@@ -0,0 +1,163 @@
+package Tie::Scalar;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
+
+=head1 SYNOPSIS
+
+ package NewScalar;
+ require Tie::Scalar;
+
+ @ISA = qw(Tie::Scalar);
+
+ sub FETCH { ... } # Provide a needed method
+ sub TIESCALAR { ... } # Overrides inherited method
+
+
+ package NewStdScalar;
+ require Tie::Scalar;
+
+ @ISA = qw(Tie::StdScalar);
+
+ # All methods provided by default, so define only what needs be overridden
+ sub FETCH { ... }
+
+
+ package main;
+
+ tie $new_scalar, 'NewScalar';
+ tie $new_std_scalar, 'NewStdScalar';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for scalar-tying classes. See
+L<perltie> for a list of the functions required in tying a scalar to a
+package. The basic B<Tie::Scalar> package provides a C<new> method, as well
+as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar>
+package provides all the methods specified in L<perltie>. It inherits from
+B<Tie::Scalar> and causes scalars tied to it to behave exactly like the
+built-in scalars, allowing for selective overloading of methods. The C<new>
+method is provided as a means of grandfathering, for classes that forget to
+provide their own C<TIESCALAR> method.
+
+For developers wishing to write their own tied-scalar classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over 4
+
+=item TIESCALAR classname, LIST
+
+The method invoked by the command C<tie $scalar, classname>. Associates a new
+scalar instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item FETCH this
+
+Retrieve the value of the tied scalar referenced by I<this>.
+
+=item STORE this, value
+
+Store data I<value> in the tied scalar referenced by I<this>.
+
+=item DESTROY this
+
+Free the storage associated with the tied scalar referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head2 Tie::Scalar vs Tie::StdScalar
+
+C<< Tie::Scalar >> provides all the necessary methods, but one should realize
+they do not do anything useful. Calling C<< Tie::Scalar::FETCH >> or
+C<< Tie::Scalar::STORE >> results in a (trappable) croak. And if you inherit
+from C<< Tie::Scalar >>, you I<must> provide either a C<< new >> or a
+C<< TIESCALAR >> method.
+
+If you are looking for a class that does everything for you you don't
+define yourself, use the C<< Tie::StdScalar >> class, not the
+C<< Tie::Scalar >> one.
+
+=head1 MORE INFORMATION
+
+The L<perltie> section uses a good example of tying scalars by associating
+process IDs with priority.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIESCALAR(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIESCALAR {
+ my $pkg = shift;
+ my $pkg_new = $pkg -> can ('new');
+
+ if ($pkg_new and $pkg ne __PACKAGE__) {
+ my $my_new = __PACKAGE__ -> can ('new');
+ if ($pkg_new == $my_new) {
+ #
+ # Prevent recursion
+ #
+ croak "$pkg must define either a TIESCALAR() or a new() method";
+ }
+
+ warnings::warnif ("WARNING: calling ${pkg}->new since " .
+ "${pkg}->TIESCALAR is missing");
+ $pkg -> new (@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIESCALAR method";
+ }
+}
+
+sub FETCH {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a FETCH method";
+}
+
+sub STORE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a STORE method";
+}
+
+#
+# The Tie::StdScalar package provides scalars that behave exactly like
+# Perl's built-in scalars. Good base to inherit from, if you're only going to
+# tweak a small bit.
+#
+package Tie::StdScalar;
+@ISA = qw(Tie::Scalar);
+
+sub TIESCALAR {
+ my $class = shift;
+ my $instance = shift || undef;
+ return bless \$instance => $class;
+}
+
+sub FETCH {
+ return ${$_[0]};
+}
+
+sub STORE {
+ ${$_[0]} = $_[1];
+}
+
+sub DESTROY {
+ undef ${$_[0]};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tie/StdHandle.pm b/Master/tlpkg/tlperl/lib/Tie/StdHandle.pm
new file mode 100644
index 00000000000..3a1a3db4788
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/StdHandle.pm
@@ -0,0 +1,71 @@
+package Tie::StdHandle;
+
+use strict;
+
+use Tie::Handle;
+use vars qw(@ISA $VERSION);
+@ISA = 'Tie::Handle';
+$VERSION = '4.2';
+
+=head1 NAME
+
+Tie::StdHandle - base class definitions for tied handles
+
+=head1 SYNOPSIS
+
+ package NewHandle;
+ require Tie::Handle;
+
+ @ISA = qw(Tie::Handle);
+
+ sub READ { ... } # Provide a needed method
+ sub TIEHANDLE { ... } # Overrides inherited method
+
+
+ package main;
+
+ tie *FH, 'NewHandle';
+
+=head1 DESCRIPTION
+
+The B<Tie::StdHandle> package provide most methods for file handles described
+in L<perltie> (the exceptions are C<UNTIE> and C<DESTROY>). It causes tied
+file handles to behave exactly like standard file handles and allow for
+selective overwriting of methods.
+
+=cut
+
+sub TIEHANDLE
+{
+ my $class = shift;
+ my $fh = \do { local *HANDLE};
+ bless $fh,$class;
+ $fh->OPEN(@_) if (@_);
+ return $fh;
+}
+
+sub EOF { eof($_[0]) }
+sub TELL { tell($_[0]) }
+sub FILENO { fileno($_[0]) }
+sub SEEK { seek($_[0],$_[1],$_[2]) }
+sub CLOSE { close($_[0]) }
+sub BINMODE { binmode($_[0]) }
+
+sub OPEN
+{
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
+}
+
+sub READ { read($_[0],$_[1],$_[2]) }
+sub READLINE { my $fh = $_[0]; <$fh> }
+sub GETC { getc($_[0]) }
+
+sub WRITE
+{
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm b/Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm
new file mode 100644
index 00000000000..476dd686787
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm
@@ -0,0 +1,215 @@
+package Tie::SubstrHash;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+
+=head1 SYNOPSIS
+
+ require Tie::SubstrHash;
+
+ tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
+
+=head1 DESCRIPTION
+
+The B<Tie::SubstrHash> package provides a hash-table-like interface to
+an array of determinate size, with constant key size and record size.
+
+Upon tying a new hash to this package, the developer must specify the
+size of the keys that will be used, the size of the value fields that the
+keys will index, and the size of the overall table (in terms of key-value
+pairs, not size in hard memory). I<These values will not change for the
+duration of the tied hash>. The newly-allocated hash table may now have
+data stored and retrieved. Efforts to store more than C<$table_size>
+elements will result in a fatal error, as will efforts to store a value
+not exactly C<$value_len> characters in length, or reference through a
+key not exactly C<$key_len> characters in length. While these constraints
+may seem excessive, the result is a hash table using much less internal
+memory than an equivalent freely-allocated hash table.
+
+=head1 CAVEATS
+
+Because the current implementation uses the table and key sizes for the
+hashing algorithm, there is no means by which to dynamically change the
+value of any of the initialization parameters.
+
+The hash does not support exists().
+
+=cut
+
+use Carp;
+
+sub TIEHASH {
+ my $pack = shift;
+ my ($klen, $vlen, $tsize) = @_;
+ my $rlen = 1 + $klen + $vlen;
+ $tsize = [$tsize,
+ findgteprime($tsize * 1.1)]; # Allow 10% empty.
+ local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+ $$self[0] x= $rlen * $tsize->[1];
+ $self;
+}
+
+sub CLEAR {
+ local($self) = @_;
+ $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
+ $$self[5] = 0;
+ $$self[6] = -1;
+}
+
+sub FETCH {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ return substr($record, 1+$klen, $vlen);
+ }
+ &rehash;
+ }
+}
+
+sub STORE {
+ local($self,$key,$val) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
+ croak(qq/Value "$val" is not $vlen characters long/)
+ if length($val) != $vlen;
+ my $writeoffset;
+
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ $writeoffset = $offset unless defined $writeoffset;
+ substr($$self[0], $writeoffset, $rlen) = $record;
+ ++$$self[5];
+ return;
+ }
+ elsif (ord($record) == 1) {
+ $writeoffset = $offset unless defined $writeoffset;
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ substr($$self[0], $offset, $rlen) = $record;
+ return;
+ }
+ &rehash;
+ }
+}
+
+sub DELETE {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ substr($$self[0], $offset, 1) = "\1";
+ return substr($record, 1+$klen, $vlen);
+ --$$self[5];
+ }
+ &rehash;
+ }
+}
+
+sub FIRSTKEY {
+ local($self) = @_;
+ $$self[6] = -1;
+ &NEXTKEY;
+}
+
+sub NEXTKEY {
+ local($self) = @_;
+ local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+ for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
+ next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+ $$self[6] = $iterix;
+ return substr($$self[0], $iterix * $rlen + 1, $klen);
+ }
+ $$self[6] = -1;
+ undef;
+}
+
+sub EXISTS {
+ croak "Tie::SubstrHash does not support exists()";
+}
+
+sub hashkey {
+ croak(qq/Key "$key" is not $klen characters long/)
+ if length($key) != $klen;
+ $hash = 2;
+ for (unpack('C*', $key)) {
+ $hash = $hash * 33 + $_;
+ &_hashwrap if $hash >= 1e13;
+ }
+ &_hashwrap if $hash >= $tsize->[1];
+ $hash = 1 unless $hash;
+ $hashbase = $hash;
+}
+
+sub _hashwrap {
+ $hash -= int($hash / $tsize->[1]) * $tsize->[1];
+}
+
+sub rehash {
+ $hash += $hashbase;
+ $hash -= $tsize->[1] if $hash >= $tsize->[1];
+}
+
+# using POSIX::ceil() would be too heavy, and not all platforms have it.
+sub ceil {
+ my $num = shift;
+ $num = int($num + 1) unless $num == int $num;
+ return $num;
+}
+
+# See:
+#
+# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
+#
+
+sub findgteprime { # find the smallest prime integer greater than or equal to
+ use integer;
+
+ my $num = ceil(shift);
+ return 2 if $num <= 2;
+
+ $num++ unless $num % 2;
+ my $i;
+ my $sqrtnum = int sqrt $num;
+ my $sqrtnumsquared = $sqrtnum * $sqrtnum;
+
+ NUM:
+ for (;; $num += 2) {
+ if ($sqrtnumsquared < $num) {
+ $sqrtnum++;
+ $sqrtnumsquared = $sqrtnum * $sqrtnum;
+ }
+ for ($i = 3; $i <= $sqrtnum; $i += 2) {
+ next NUM unless $num % $i;
+ }
+ return $num;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tie/Watch.pm b/Master/tlpkg/tlperl/lib/Tie/Watch.pm
new file mode 100644
index 00000000000..9882751073d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tie/Watch.pm
@@ -0,0 +1,560 @@
+$Tie::Watch::VERSION = '1.3';
+
+package Tie::Watch;
+
+=head1 NAME
+
+ Tie::Watch - place watchpoints on Perl variables.
+
+=head1 SYNOPSIS
+
+ use Tie::Watch;
+
+ $watch = Tie::Watch->new(
+ -variable => \$frog,
+ -debug => 1,
+ -shadow => 0,
+ -fetch => [\&fetch, 'arg1', 'arg2', ..., 'argn'],
+ -store => \&store,
+ -destroy => sub {print "Final value=$frog.\n"},
+ }
+ %vinfo = $watch->Info;
+ $args = $watch->Args(-fetch);
+ $val = $watch->Fetch;
+ print "val=", $watch->Say($val), ".\n";
+ $watch->Store('Hello');
+ $watch->Unwatch;
+
+=head1 DESCRIPTION
+
+This class module binds one or more subroutines of your devising to a
+Perl variable. All variables can have B<FETCH>, B<STORE> and
+B<DESTROY> callbacks. Additionally, arrays can define B<CLEAR>,
+B<DELETE>, B<EXISTS>, B<EXTEND>, B<FETCHSIZE>, B<POP>, B<PUSH>,
+B<SHIFT>, B<SPLICE>, B<STORESIZE> and B<UNSHIFT> callbacks, and hashes
+can define B<CLEAR>, B<DELETE>, B<EXISTS>, B<FIRSTKEY> and B<NEXTKEY>
+callbacks. If these term are unfamiliar to you, I I<really> suggest
+you read L<perltie>.
+
+With Tie::Watch you can:
+
+ . alter a variable's value
+ . prevent a variable's value from being changed
+ . invoke a Perl/Tk callback when a variable changes
+ . trace references to a variable
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments. (See examples in the Synopsis, above.)
+
+Tie::Watch provides default callbacks for any that you fail to
+specify. Other than negatively impacting performance, they perform
+the standard action that you'd expect, so the variable behaves
+"normally". Once you override a default callback, perhaps to insert
+debug code like print statements, your callback normally finishes by
+calling the underlying (overridden) method. But you don't have to!
+
+To map a tied method name to a default callback name simply lowercase
+the tied method name and uppercase its first character. So FETCH
+becomes Fetch, NEXTKEY becomes Nextkey, etcetera.
+
+Here are two callbacks for a scalar. The B<FETCH> (read) callback does
+nothing other than illustrate the fact that it returns the value to
+assign the variable. The B<STORE> (write) callback uppercases the
+variable and returns it. In all cases the callback I<must> return the
+correct read or write value - typically, it does this by invoking the
+underlying method.
+
+ my $fetch_scalar = sub {
+ my($self) = @_;
+ $self->Fetch;
+ };
+
+ my $store_scalar = sub {
+ my($self, $new_val) = @_;
+ $self->Store(uc $new_val);
+ };
+
+Here are B<FETCH> and B<STORE> callbacks for either an array or hash.
+They do essentially the same thing as the scalar callbacks, but
+provide a little more information.
+
+ my $fetch = sub {
+ my($self, $key) = @_;
+ my $val = $self->Fetch($key);
+ print "In fetch callback, key=$key, val=", $self->Say($val);
+ my $args = $self->Args(-fetch);
+ print ", args=('", join("', '", @$args), "')" if $args;
+ print ".\n";
+ $val;
+ };
+
+ my $store = sub {
+ my($self, $key, $new_val) = @_;
+ my $val = $self->Fetch($key);
+ $new_val = uc $new_val;
+ $self->Store($key, $new_val);
+ print "In store callback, key=$key, val=", $self->Say($val),
+ ", new_val=", $self->Say($new_val);
+ my $args = $self->Args(-store);
+ print ", args=('", join("', '", @$args), "')" if $args;
+ print ".\n";
+ $new_val;
+ };
+
+In all cases, the first parameter is a reference to the Watch object,
+used to invoke the following class methods.
+
+=head1 METHODS
+
+=over 4
+
+=item $watch = Tie::Watch->new(-options => values);
+
+The watchpoint constructor method that accepts option/value pairs to
+create and configure the Watch object. The only required option is
+B<-variable>.
+
+B<-variable> is a I<reference> to a scalar, array or hash variable.
+
+B<-debug> (default 0) is 1 to activate debug print statements internal
+to Tie::Watch.
+
+B<-shadow> (default 1) is 0 to disable array and hash shadowing. To
+prevent infinite recursion Tie::Watch maintains parallel variables for
+arrays and hashes. When the watchpoint is created the parallel shadow
+variable is initialized with the watched variable's contents, and when
+the watchpoint is deleted the shadow variable is copied to the original
+variable. Thus, changes made during the watch process are not lost.
+Shadowing is on my default. If you disable shadowing any changes made
+to an array or hash are lost when the watchpoint is deleted.
+
+Specify any of the following relevant callback parameters, in the
+format described above: B<-fetch>, B<-store>, B<-destroy>.
+Additionally for arrays: B<-clear>, B<-extend>, B<-fetchsize>,
+B<-pop>, B<-push>, B<-shift>, B<-splice>, B<-storesize> and
+B<-unshift>. Additionally for hashes: B<-clear>, B<-delete>,
+B<-exists>, B<-firstkey> and B<-nextkey>.
+
+=item $args = $watch->Args(-fetch);
+
+Returns a reference to a list of arguments for the specified callback,
+or undefined if none.
+
+=item $watch->Fetch(); $watch->Fetch($key);
+
+Returns a variable's current value. $key is required for an array or
+hash.
+
+=item %vinfo = $watch->Info();
+
+Returns a hash detailing the internals of the Watch object, with these
+keys:
+
+ %vinfo = {
+ -variable => SCALAR(0x200737f8)
+ -debug => '0'
+ -shadow => '1'
+ -value => 'HELLO SCALAR'
+ -destroy => ARRAY(0x200f86cc)
+ -fetch => ARRAY(0x200f8558)
+ -store => ARRAY(0x200f85a0)
+ -legible => above data formatted as a list of string, for printing
+ }
+
+For array and hash Watch objects, the B<-value> key is replaced with a
+B<-ptr> key which is a reference to the parallel array or hash.
+Additionally, for an array or hash, there are key/value pairs for
+all the variable specific callbacks.
+
+=item $watch->Say($val);
+
+Used mainly for debugging, it returns $val in quotes if required, or
+the string "undefined" for undefined values.
+
+=item $watch->Store($new_val); $watch->Store($key, $new_val);
+
+Store a variable's new value. $key is required for an array or hash.
+
+=item $watch->Unwatch();
+
+Stop watching the variable.
+
+=back
+
+=head1 EFFICIENCY CONSIDERATIONS
+
+If you can live using the class methods provided, please do so. You
+can meddle with the object hash directly and improved watch
+performance, at the risk of your code breaking in the future.
+
+=head1 AUTHOR
+
+Stephen O. Lidie
+
+=head1 HISTORY
+
+ lusol@Lehigh.EDU, LUCC, 96/05/30
+ . Original version 0.92 release, based on the Trace module from Hans Mulder,
+ and ideas from Tim Bunce.
+
+ lusol@Lehigh.EDU, LUCC, 96/12/25
+ . Version 0.96, release two inner references detected by Perl 5.004.
+
+ lusol@Lehigh.EDU, LUCC, 97/01/11
+ . Version 0.97, fix Makefile.PL and MANIFEST (thanks Andreas Koenig).
+ Make sure test.pl doesn't fail if Tk isn't installed.
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 97/10/03
+ . Version 0.98, implement -shadow option for arrays and hashes.
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 98/02/11
+ . Version 0.99, finally, with Perl 5.004_57, we can completely watch arrays.
+ With tied array support this module is essentially complete, so its been
+ optimized for speed at the expense of clarity - sorry about that. The
+ Delete() method has been renamed Unwatch() because it conflicts with the
+ builtin delete().
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 99/04/04
+ . Version 1.0, for Perl 5.005_03, update Makefile.PL for ActiveState, and
+ add two examples (one for Perl/Tk).
+
+ sol0@lehigh.edu, Lehigh University Computing Center, 2003/06/07
+ . Version 1.1, for Perl 5.8, can trace a reference now, patch from Slaven
+ Rezic.
+
+ sol0@lehigh.edu, Lehigh University Computing Center, 2005/05/17
+ . Version 1.2, for Perl 5.8, per Rob Seegel's suggestion, support array
+ DELETE and EXISTS.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1996 - 2005 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+use 5.004_57;;
+use Carp;
+use strict;
+use subs qw/normalize_callbacks/;
+use vars qw/@array_callbacks @hash_callbacks @scalar_callbacks/;
+
+@array_callbacks = qw/-clear -delete -destroy -exists -extend -fetch
+ -fetchsize -pop -push -shift -splice -store
+ -storesize -unshift/;
+@hash_callbacks = qw/-clear -delete -destroy -exists -fetch -firstkey
+ -nextkey -store/;
+@scalar_callbacks = qw/-destroy -fetch -store/;
+
+sub new {
+
+ # Watch constructor. The *real* constructor is Tie::Watch->base_watch(),
+ # invoked by methods in other Watch packages, depending upon the variable's
+ # type. Here we supply defaulted parameter values and then verify them,
+ # normalize all callbacks and bind the variable to the appropriate package.
+
+ my($class, %args) = @_;
+ my $version = $Tie::Watch::VERSION;
+ my (%arg_defaults) = (-debug => 0, -shadow => 1);
+ my $variable = $args{-variable};
+ croak "Tie::Watch::new(): -variable is required." if not defined $variable;
+
+ my($type, $watch_obj) = (ref $variable, undef);
+ if ($type =~ /(SCALAR|REF)/) {
+ @arg_defaults{@scalar_callbacks} = (
+ [\&Tie::Watch::Scalar::Destroy], [\&Tie::Watch::Scalar::Fetch],
+ [\&Tie::Watch::Scalar::Store]);
+ } elsif ($type =~ /ARRAY/) {
+ @arg_defaults{@array_callbacks} = (
+ [\&Tie::Watch::Array::Clear], [\&Tie::Watch::Array::Delete],
+ [\&Tie::Watch::Array::Destroy], [\&Tie::Watch::Array::Exists],
+ [\&Tie::Watch::Array::Extend], [\&Tie::Watch::Array::Fetch],
+ [\&Tie::Watch::Array::Fetchsize], [\&Tie::Watch::Array::Pop],
+ [\&Tie::Watch::Array::Push], [\&Tie::Watch::Array::Shift],
+ [\&Tie::Watch::Array::Splice], [\&Tie::Watch::Array::Store],
+ [\&Tie::Watch::Array::Storesize], [\&Tie::Watch::Array::Unshift]);
+ } elsif ($type =~ /HASH/) {
+ @arg_defaults{@hash_callbacks} = (
+ [\&Tie::Watch::Hash::Clear], [\&Tie::Watch::Hash::Delete],
+ [\&Tie::Watch::Hash::Destroy], [\&Tie::Watch::Hash::Exists],
+ [\&Tie::Watch::Hash::Fetch], [\&Tie::Watch::Hash::Firstkey],
+ [\&Tie::Watch::Hash::Nextkey], [\&Tie::Watch::Hash::Store]);
+ } else {
+ croak "Tie::Watch::new() - not a variable reference.";
+ }
+ my(@margs, %ahsh, $args, @args);
+ @margs = grep ! defined $args{$_}, keys %arg_defaults;
+ %ahsh = %args; # argument hash
+ @ahsh{@margs} = @arg_defaults{@margs}; # fill in missing values
+ normalize_callbacks \%ahsh;
+
+ if ($type =~ /(SCALAR|REF)/) {
+ $watch_obj = tie $$variable, 'Tie::Watch::Scalar', %ahsh;
+ } elsif ($type =~ /ARRAY/) {
+ $watch_obj = tie @$variable, 'Tie::Watch::Array', %ahsh;
+ } elsif ($type =~ /HASH/) {
+ $watch_obj = tie %$variable, 'Tie::Watch::Hash', %ahsh;
+ }
+ $watch_obj;
+
+} # end new, Watch constructor
+
+sub Args {
+
+ # Return a reference to a list of callback arguments, or undef if none.
+ #
+ # $_[0] = self
+ # $_[1] = callback type
+
+ defined $_[0]->{$_[1]}->[1] ? [@{$_[0]->{$_[1]}}[1 .. $#{$_[0]->{$_[1]}}]]
+ : undef;
+
+} # end Args
+
+sub Info {
+
+ # Info() method subclassed by other Watch modules.
+ #
+ # $_[0] = self
+ # @_[1 .. $#_] = optional callback types
+
+ my(%vinfo, @results);
+ my(@info) = (qw/-variable -debug -shadow/);
+ push @info, @_[1 .. $#_] if scalar @_ >= 2;
+ foreach my $type (@info) {
+ push @results, sprintf('%-10s: ', substr $type, 1) .
+ $_[0]->Say($_[0]->{$type});
+ $vinfo{$type} = $_[0]->{$type};
+ }
+ $vinfo{-legible} = [@results];
+ %vinfo;
+
+} # end Info
+
+sub Say {
+
+ # For debugging, mainly.
+ #
+ # $_[0] = self
+ # $_[1] = value
+
+ defined $_[1] ? (ref($_[1]) ne '' ? $_[1] : "'$_[1]'") : "undefined";
+
+} # end Say
+
+sub Unwatch {
+
+ # Stop watching a variable by releasing the last reference and untieing it.
+ # Update the original variable with its shadow, if appropriate.
+ #
+ # $_[0] = self
+
+ my $variable = $_[0]->{-variable};
+ my $type = ref $variable;
+ my $copy; $copy = $_[0]->{-ptr} if $type !~ /(SCALAR|REF)/;
+ my $shadow = $_[0]->{-shadow};
+ undef $_[0];
+ if ($type =~ /(SCALAR|REF)/) {
+ untie $$variable;
+ } elsif ($type =~ /ARRAY/) {
+ untie @$variable;
+ @$variable = @$copy if $shadow;
+ } elsif ($type =~ /HASH/) {
+ untie %$variable;
+ %$variable = %$copy if $shadow;
+ } else {
+ croak "Tie::Watch::Delete() - not a variable reference.";
+ }
+
+} # end Unwatch
+
+# Watch private methods.
+
+sub base_watch {
+
+ # Watch base class constructor invoked by other Watch modules.
+
+ my($class, %args) = @_;
+ my $watch_obj = {%args};
+ $watch_obj;
+
+} # end base_watch
+
+sub callback {
+
+ # Execute a Watch callback, either the default or user specified.
+ # Note that the arguments are those supplied by the tied method,
+ # not those (if any) specified by the user when the watch object
+ # was instantiated. This is for performance reasons, and why the
+ # Args() method exists.
+ #
+ # $_[0] = self
+ # $_[1] = callback type
+ # $_[2] through $#_ = tied arguments
+
+ &{$_[0]->{$_[1]}->[0]} ($_[0], @_[2 .. $#_]);
+
+} # end callback
+
+sub normalize_callbacks {
+
+ # Ensure all callbacks are normalized in [\&code, @args] format.
+
+ my($args_ref) = @_;
+ my($cb, $ref);
+ foreach my $arg (keys %$args_ref) {
+ next if $arg =~ /variable|debug|shadow/;
+ $cb = $args_ref->{$arg};
+ $ref = ref $cb;
+ if ($ref =~ /CODE/) {
+ $args_ref->{$arg} = [$cb];
+ } elsif ($ref !~ /ARRAY/) {
+ croak "Tie::Watch: malformed callback $arg=$cb.";
+ }
+ }
+
+} # end normalize_callbacks
+
+###############################################################################
+
+package Tie::Watch::Scalar;
+
+use Carp;
+@Tie::Watch::Scalar::ISA = qw/Tie::Watch/;
+
+sub TIESCALAR {
+
+ my($class, %args) = @_;
+ my $variable = $args{-variable};
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ $watch_obj->{-value} = $$variable;
+ print "WatchScalar new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIESCALAR
+
+sub Info {$_[0]->SUPER::Info('-value', @Tie::Watch::scalar_callbacks)}
+
+# Default scalar callbacks.
+
+sub Destroy {undef %{$_[0]}}
+sub Fetch {$_[0]->{-value}}
+sub Store {$_[0]->{-value} = $_[1]}
+
+# Scalar access methods.
+
+sub DESTROY {$_[0]->callback('-destroy')}
+sub FETCH {$_[0]->callback('-fetch')}
+sub STORE {$_[0]->callback('-store', $_[1])}
+
+###############################################################################
+
+package Tie::Watch::Array;
+
+use Carp;
+@Tie::Watch::Array::ISA = qw/Tie::Watch/;
+
+sub TIEARRAY {
+
+ my($class, %args) = @_;
+ my($variable, $shadow) = @args{-variable, -shadow};
+ my @copy; @copy = @$variable if $shadow; # make a private copy of user's array
+ $args{-ptr} = $shadow ? \@copy : [];
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ print "WatchArray new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIEARRAY
+
+sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::array_callbacks)}
+
+# Default array callbacks.
+
+sub Clear {$_[0]->{-ptr} = ()}
+sub Delete {delete $_[0]->{-ptr}->[$_[1]]}
+sub Destroy {undef %{$_[0]}}
+sub Exists {exists $_[0]->{-ptr}->[$_[1]]}
+sub Extend {}
+sub Fetch {$_[0]->{-ptr}->[$_[1]]}
+sub Fetchsize {scalar @{$_[0]->{-ptr}}}
+sub Pop {pop @{$_[0]->{-ptr}}}
+sub Push {push @{$_[0]->{-ptr}}, @_[1 .. $#_]}
+sub Shift {shift @{$_[0]->{-ptr}}}
+sub Splice {
+ my $n = scalar @_; # splice() is wierd!
+ return splice @{$_[0]->{-ptr}}, $_[1] if $n == 2;
+ return splice @{$_[0]->{-ptr}}, $_[1], $_[2] if $n == 3;
+ return splice @{$_[0]->{-ptr}}, $_[1], $_[2], @_[3 .. $#_] if $n >= 4;
+}
+sub Store {$_[0]->{-ptr}->[$_[1]] = $_[2]}
+sub Storesize {$#{$_[0]->{-ptr}} = $_[1] - 1}
+sub Unshift {unshift @{$_[0]->{-ptr}}, @_[1 .. $#_]}
+
+# Array access methods.
+
+sub CLEAR {$_[0]->callback('-clear')}
+sub DELETE {$_[0]->callback('-delete', $_[1])}
+sub DESTROY {$_[0]->callback('-destroy')}
+sub EXISTS {$_[0]->callback('-exists', $_[1])}
+sub EXTEND {$_[0]->callback('-extend', $_[1])}
+sub FETCH {$_[0]->callback('-fetch', $_[1])}
+sub FETCHSIZE {$_[0]->callback('-fetchsize')}
+sub POP {$_[0]->callback('-pop')}
+sub PUSH {$_[0]->callback('-push', @_[1 .. $#_])}
+sub SHIFT {$_[0]->callback('-shift')}
+sub SPLICE {$_[0]->callback('-splice', @_[1 .. $#_])}
+sub STORE {$_[0]->callback('-store', $_[1], $_[2])}
+sub STORESIZE {$_[0]->callback('-storesize', $_[1])}
+sub UNSHIFT {$_[0]->callback('-unshift', @_[1 .. $#_])}
+
+###############################################################################
+
+package Tie::Watch::Hash;
+
+use Carp;
+@Tie::Watch::Hash::ISA = qw/Tie::Watch/;
+
+sub TIEHASH {
+
+ my($class, %args) = @_;
+ my($variable, $shadow) = @args{-variable, -shadow};
+ my %copy; %copy = %$variable if $shadow; # make a private copy of user's hash
+ $args{-ptr} = $shadow ? \%copy : {};
+ my $watch_obj = Tie::Watch->base_watch(%args);
+ print "WatchHash new: $variable created, \@_=", join(',', @_), "!\n"
+ if $watch_obj->{-debug};
+ bless $watch_obj, $class;
+
+} # end TIEHASH
+
+sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::hash_callbacks)}
+
+# Default hash callbacks.
+
+sub Clear {$_[0]->{-ptr} = ()}
+sub Delete {delete $_[0]->{-ptr}->{$_[1]}}
+sub Destroy {undef %{$_[0]}}
+sub Exists {exists $_[0]->{-ptr}->{$_[1]}}
+sub Fetch {$_[0]->{-ptr}->{$_[1]}}
+sub Firstkey {my $c = keys %{$_[0]->{-ptr}}; each %{$_[0]->{-ptr}}}
+sub Nextkey {each %{$_[0]->{-ptr}}}
+sub Store {$_[0]->{-ptr}->{$_[1]} = $_[2]}
+
+# Hash access methods.
+
+sub CLEAR {$_[0]->callback('-clear')}
+sub DELETE {$_[0]->callback('-delete', $_[1])}
+sub DESTROY {$_[0]->callback('-destroy')}
+sub EXISTS {$_[0]->callback('-exists', $_[1])}
+sub FETCH {$_[0]->callback('-fetch', $_[1])}
+sub FIRSTKEY {$_[0]->callback('-firstkey')}
+sub NEXTKEY {$_[0]->callback('-nextkey')}
+sub STORE {$_[0]->callback('-store', $_[1], $_[2])}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Time/HiRes.pm b/Master/tlpkg/tlperl/lib/Time/HiRes.pm
new file mode 100644
index 00000000000..da4d45a96e8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/HiRes.pm
@@ -0,0 +1,591 @@
+package Time::HiRes;
+
+use strict;
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(Exporter DynaLoader);
+
+@EXPORT = qw( );
+@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+ getitimer setitimer nanosleep clock_gettime clock_getres
+ clock clock_nanosleep
+ CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
+ CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
+ CLOCK_TIMEOFDAY CLOCKS_PER_SEC
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
+ TIMER_ABSTIME
+ d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
+ d_nanosleep d_clock_gettime d_clock_getres
+ d_clock d_clock_nanosleep
+ stat
+ );
+
+$VERSION = '1.9719';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+sub AUTOLOAD {
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
+ die "&Time::HiRes::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ # print "AUTOLOAD: error = $error, val = $val\n";
+ if ($error) {
+ my (undef,$file,$line) = caller;
+ die "$error at $file line $line.\n";
+ }
+ {
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+}
+
+sub import {
+ my $this = shift;
+ for my $i (@_) {
+ if (($i eq 'clock_getres' && !&d_clock_getres) ||
+ ($i eq 'clock_gettime' && !&d_clock_gettime) ||
+ ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
+ ($i eq 'clock' && !&d_clock) ||
+ ($i eq 'nanosleep' && !&d_nanosleep) ||
+ ($i eq 'usleep' && !&d_usleep) ||
+ ($i eq 'ualarm' && !&d_ualarm)) {
+ require Carp;
+ Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
+ }
+ }
+ Time::HiRes->export_to_level(1, $this, @_);
+}
+
+bootstrap Time::HiRes;
+
+# Preloaded methods go here.
+
+sub tv_interval {
+ # probably could have been done in C
+ my ($a, $b) = @_;
+ $b = [gettimeofday()] unless defined($b);
+ (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
+
+=head1 SYNOPSIS
+
+ use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
+ clock_gettime clock_getres clock_nanosleep clock
+ stat );
+
+ usleep ($microseconds);
+ nanosleep ($nanoseconds);
+
+ ualarm ($microseconds);
+ ualarm ($microseconds, $interval_microseconds);
+
+ $t0 = [gettimeofday];
+ ($seconds, $microseconds) = gettimeofday;
+
+ $elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
+ $elapsed = tv_interval ( $t0, [gettimeofday]);
+ $elapsed = tv_interval ( $t0 );
+
+ use Time::HiRes qw ( time alarm sleep );
+
+ $now_fractions = time;
+ sleep ($floating_seconds);
+ alarm ($floating_seconds);
+ alarm ($floating_seconds, $floating_interval);
+
+ use Time::HiRes qw( setitimer getitimer );
+
+ setitimer ($which, $floating_seconds, $floating_interval );
+ getitimer ($which);
+
+ use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
+
+ $realtime = clock_gettime(CLOCK_REALTIME);
+ $resolution = clock_getres(CLOCK_REALTIME);
+
+ clock_nanosleep(CLOCK_REALTIME, 1.5e9);
+ clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME);
+
+ my $ticktock = clock();
+
+ use Time::HiRes qw( stat );
+
+ my @stat = stat("file");
+ my @stat = stat(FH);
+
+=head1 DESCRIPTION
+
+The C<Time::HiRes> module implements a Perl interface to the
+C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
+C<setitimer>/C<getitimer> system calls, in other words, high
+resolution time and timers. See the L</EXAMPLES> section below and the
+test scripts for usage; see your system documentation for the
+description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
+C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
+
+If your system lacks C<gettimeofday()> or an emulation of it you don't
+get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
+If your system lacks all of C<nanosleep()>, C<usleep()>,
+C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
+C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
+If your system lacks both C<ualarm()> and C<setitimer()> you don't get
+C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
+
+If you try to import an unimplemented function in the C<use> statement
+it will fail at compile time.
+
+If your subsecond sleeping is implemented with C<nanosleep()> instead
+of C<usleep()>, you can mix subsecond sleeping with signals since
+C<nanosleep()> does not use signals. This, however, is not portable,
+and you should first check for the truth value of
+C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
+then carefully read your C<nanosleep()> C API documentation for any
+peculiarities.
+
+If you are using C<nanosleep> for something else than mixing sleeping
+with signals, give some thought to whether Perl is the tool you should
+be using for work requiring nanosecond accuracies.
+
+Remember that unless you are working on a I<hard realtime> system,
+any clocks and timers will be imprecise, especially so if you are working
+in a pre-emptive multiuser system. Understand the difference between
+I<wallclock time> and process time (in UNIX-like systems the sum of
+I<user> and I<system> times). Any attempt to sleep for X seconds will
+most probably end up sleeping B<more> than that, but don't be surpised
+if you end up sleeping slightly B<less>.
+
+The following functions can be imported from this module.
+No functions are exported by default.
+
+=over 4
+
+=item gettimeofday ()
+
+In array context returns a two-element array with the seconds and
+microseconds since the epoch. In scalar context returns floating
+seconds like C<Time::HiRes::time()> (see below).
+
+=item usleep ( $useconds )
+
+Sleeps for the number of microseconds (millionths of a second)
+specified. Returns the number of microseconds actually slept.
+Can sleep for more than one second, unlike the C<usleep> system call.
+Can also sleep for zero seconds, which often works like a I<thread yield>.
+See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
+C<Time::HiRes::clock_nanosleep()>.
+
+Do not expect usleep() to be exact down to one microsecond.
+
+=item nanosleep ( $nanoseconds )
+
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept (accurate only to
+microseconds, the nearest thousand of them). Can sleep for more than
+one second. Can also sleep for zero seconds, which often works like
+a I<thread yield>. See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
+
+Do not expect nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+
+=item ualarm ( $useconds [, $interval_useconds ] )
+
+Issues a C<ualarm> call; the C<$interval_useconds> is optional and
+will be zero if unspecified, resulting in C<alarm>-like behaviour.
+
+Returns the remaining time in the alarm in microseconds, or C<undef>
+if an error occurred.
+
+ualarm(0) will cancel an outstanding ualarm().
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item tv_interval
+
+tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
+
+Returns the floating seconds between the two times, which should have
+been returned by C<gettimeofday()>. If the second argument is omitted,
+then the current time is used.
+
+=item time ()
+
+Returns a floating seconds since the epoch. This function can be
+imported, resulting in a nice drop-in replacement for the C<time>
+provided with core Perl; see the L</EXAMPLES> below.
+
+B<NOTE 1>: This higher resolution timer can return values either less
+or more than the core C<time()>, depending on whether your platform
+rounds the higher resolution timer values up, down, or to the nearest second
+to get the core C<time()>, but naturally the difference should be never
+more than half a second. See also L</clock_getres>, if available
+in your system.
+
+B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
+the C<time()> seconds since epoch rolled over to 1_000_000_000, the
+default floating point format of Perl and the seconds since epoch have
+conspired to produce an apparent bug: if you print the value of
+C<Time::HiRes::time()> you seem to be getting only five decimals, not
+six as promised (microseconds). Not to worry, the microseconds are
+there (assuming your platform supports such granularity in the first
+place). What is going on is that the default floating point format of
+Perl only outputs 15 digits. In this case that means ten digits
+before the decimal separator and five after. To see the microseconds
+you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
+C<gettimeofday()> function in list context, which will give you the
+seconds and microseconds as two separate values.
+
+=item sleep ( $floating_seconds )
+
+Sleeps for the specified amount of seconds. Returns the number of
+seconds actually slept (a floating point value). This function can
+be imported, resulting in a nice drop-in replacement for the C<sleep>
+provided with perl, see the L</EXAMPLES> below.
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
+
+The C<SIGALRM> signal is sent after the specified number of seconds.
+Implemented using C<setitimer()> if available, C<ualarm()> if not.
+The C<$interval_floating_seconds> argument is optional and will be
+zero if unspecified, resulting in C<alarm()>-like behaviour. This
+function can be imported, resulting in a nice drop-in replacement for
+the C<alarm> provided with perl, see the L</EXAMPLES> below.
+
+Returns the remaining time in the alarm in seconds, or C<undef>
+if an error occurred.
+
+B<NOTE 1>: With some combinations of operating systems and Perl
+releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
+This means that an C<alarm()> followed by a C<select()> may together
+take the sum of the times specified for the the C<alarm()> and the
+C<select()>, not just the time of the C<alarm()>.
+
+Note that the interaction between alarms and sleeps is unspecified.
+
+=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
+
+Start up an interval timer: after a certain time, a signal ($which) arrives,
+and more signals may keep arriving at certain intervals. To disable
+an "itimer", use C<$floating_seconds> of zero. If the
+C<$interval_floating_seconds> is set to zero (or unspecified), the
+timer is disabled B<after> the next delivered signal.
+
+Use of interval timers may interfere with C<alarm()>, C<sleep()>,
+and C<usleep()>. In standard-speak the "interaction is unspecified",
+which means that I<anything> may happen: it may work, it may not.
+
+In scalar context, the remaining time in the timer is returned.
+
+In list context, both the remaining time and the interval are returned.
+
+There are usually three or four interval timers (signals) available: the
+C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
+C<ITIMER_REALPROF>. Note that which ones are available depends: true
+UNIX platforms usually have the first three, but only Solaris seems to
+have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+Win32 unfortunately does not haveinterval timers.
+
+C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
+I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
+the timer expires.
+
+C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
+only when the process is running. In multiprocessor/user/CPU systems
+this may be more or less than real or wallclock time. (This time is
+also known as the I<user time>.) C<SIGVTALRM> is delivered when the
+timer expires.
+
+C<ITIMER_PROF> counts time when either the process virtual time or when
+the operating system is running on behalf of the process (such as I/O).
+(This time is also known as the I<system time>.) (The sum of user
+time and system time is known as the I<CPU time>.) C<SIGPROF> is
+delivered when the timer expires. C<SIGPROF> can interrupt system calls.
+
+The semantics of interval timers for multithreaded programs are
+system-specific, and some systems may support additional interval
+timers. For example, it is unspecified which thread gets the signals.
+See your C<setitimer()> documentation.
+
+=item getitimer ( $which )
+
+Return the remaining time in the interval timer specified by C<$which>.
+
+In scalar context, the remaining time is returned.
+
+In list context, both the remaining time and the interval are returned.
+The interval is always what you put in using C<setitimer()>.
+
+=item clock_gettime ( $which )
+
+Return as seconds the current value of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, which is supposed to return results close to the
+results of C<gettimeofday>, or the number of seconds since 00:00:00:00
+January 1, 1970 Greenwich Mean Time (GMT). Do not assume that
+CLOCK_REALTIME is zero, it might be one, or something else.
+Another potentially useful (but not available everywhere) value is
+C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
+value (unlike time() or gettimeofday(), which can be adjusted).
+See your system documentation for other possibly supported values.
+
+=item clock_getres ( $which )
+
+Return as seconds the resolution of the POSIX high resolution timer
+specified by C<$which>. All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, see L</clock_gettime>.
+
+=item clock_nanosleep ( $which, $nanoseconds, $flags = 0)
+
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept. The $which is the
+"clock id", as with clock_gettime() and clock_getres(). The flags
+default to zero but C<TIMER_ABSTIME> can specified (must be exported
+explicitly) which means that C<$nanoseconds> is not a time interval
+(as is the default) but instead an absolute time. Can sleep for more
+than one second. Can also sleep for zero seconds, which often works
+like a I<thread yield>. See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
+
+Do not expect clock_nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+
+=item clock()
+
+Return as seconds the I<process time> (user + system time) spent by
+the process since the first call to clock() (the definition is B<not>
+"since the start of the process", though if you are lucky these times
+may be quite close to each other, depending on the system). What this
+means is that you probably need to store the result of your first call
+to clock(), and subtract that value from the following results of clock().
+
+The time returned also includes the process times of the terminated
+child processes for which wait() has been executed. This value is
+somewhat like the second value returned by the times() of core Perl,
+but not necessarily identical. Note that due to backward
+compatibility limitations the returned value may wrap around at about
+2147 seconds or at about 36 minutes.
+
+=item stat
+
+=item stat FH
+
+=item stat EXPR
+
+As L<perlfunc/stat> but with the access/modify/change file timestamps
+in subsecond resolution, if the operating system and the filesystem
+both support such timestamps. To override the standard stat():
+
+ use Time::HiRes qw(stat);
+
+Test for the value of &Time::HiRes::d_hires_stat to find out whether
+the operating system supports subsecond file timestamps: a value
+larger than zero means yes. There are unfortunately no easy
+ways to find out whether the filesystem supports such timestamps.
+UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp
+granularity is B<two> seconds).
+
+A zero return value of &Time::HiRes::d_hires_stat means that
+Time::HiRes::stat is a no-op passthrough for CORE::stat(),
+and therefore the timestamps will stay integers. The same
+thing will happen if the filesystem does not do subsecond timestamps,
+even if the &Time::HiRes::d_hires_stat is non-zero.
+
+In any case do not expect nanosecond resolution, or even a microsecond
+resolution. Also note that the modify/access timestamps might have
+different resolutions, and that they need not be synchronized, e.g.
+if the operations are
+
+ write
+ stat # t1
+ read
+ stat # t2
+
+the access time stamp from t2 need not be greater-than the modify
+time stamp from t1: it may be equal or I<less>.
+
+=back
+
+=head1 EXAMPLES
+
+ use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
+
+ $microseconds = 750_000;
+ usleep($microseconds);
+
+ # signal alarm in 2.5s & every .1s thereafter
+ ualarm(2_500_000, 100_000);
+ # cancel that ualarm
+ ualarm(0);
+
+ # get seconds and microseconds since the epoch
+ ($s, $usec) = gettimeofday();
+
+ # measure elapsed time
+ # (could also do by subtracting 2 gettimeofday return values)
+ $t0 = [gettimeofday];
+ # do bunch of stuff here
+ $t1 = [gettimeofday];
+ # do more stuff here
+ $t0_t1 = tv_interval $t0, $t1;
+
+ $elapsed = tv_interval ($t0, [gettimeofday]);
+ $elapsed = tv_interval ($t0); # equivalent code
+
+ #
+ # replacements for time, alarm and sleep that know about
+ # floating seconds
+ #
+ use Time::HiRes;
+ $now_fractions = Time::HiRes::time;
+ Time::HiRes::sleep (2.5);
+ Time::HiRes::alarm (10.6666666);
+
+ use Time::HiRes qw ( time alarm sleep );
+ $now_fractions = time;
+ sleep (2.5);
+ alarm (10.6666666);
+
+ # Arm an interval timer to go off first at 10 seconds and
+ # after that every 2.5 seconds, in process virtual time
+
+ use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
+
+ $SIG{VTALRM} = sub { print time, "\n" };
+ setitimer(ITIMER_VIRTUAL, 10, 2.5);
+
+ use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
+ # Read the POSIX high resolution timer.
+ my $high = clock_getres(CLOCK_REALTIME);
+ # But how accurate we can be, really?
+ my $reso = clock_getres(CLOCK_REALTIME);
+
+ use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
+ clock_nanosleep(CLOCK_REALTIME, 1e6);
+ clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
+
+ use Time::HiRes qw( clock );
+ my $clock0 = clock();
+ ... # Do something.
+ my $clock1 = clock();
+ my $clockd = $clock1 - $clock0;
+
+ use Time::HiRes qw( stat );
+ my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10];
+
+=head1 C API
+
+In addition to the perl API described above, a C API is available for
+extension writers. The following C functions are available in the
+modglobal hash:
+
+ name C prototype
+ --------------- ----------------------
+ Time::NVtime double (*)()
+ Time::U2time void (*)(pTHX_ UV ret[2])
+
+Both functions return equivalent information (like C<gettimeofday>)
+but with different representations. The names C<NVtime> and C<U2time>
+were selected mainly because they are operating system independent.
+(C<gettimeofday> is Unix-centric, though some platforms like Win32 and
+VMS have emulations for it.)
+
+Here is an example of using C<NVtime> from C:
+
+ double (*myNVtime)(); /* Returns -1 on failure. */
+ SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
+ if (!svp) croak("Time::HiRes is required");
+ if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
+ myNVtime = INT2PTR(double(*)(), SvIV(*svp));
+ printf("The current time is: %f\n", (*myNVtime)());
+
+=head1 DIAGNOSTICS
+
+=head2 useconds or interval more than ...
+
+In ualarm() you tried to use number of microseconds or interval (also
+in microseconds) more than 1_000_000 and setitimer() is not available
+in your system to emulate that case.
+
+=head2 negative time not invented yet
+
+You tried to use a negative time argument.
+
+=head2 internal error: useconds < 0 (unsigned ... signed ...)
+
+Something went horribly wrong-- the number of microseconds that cannot
+become negative just became negative. Maybe your compiler is broken?
+
+=head2 useconds or uinterval equal to or more than 1000000
+
+In some platforms it is not possible to get an alarm with subsecond
+resolution and later than one second.
+
+=head2 unimplemented in this platform
+
+Some calls simply aren't available, real or emulated, on every platform.
+
+=head1 CAVEATS
+
+Notice that the core C<time()> maybe rounding rather than truncating.
+What this means is that the core C<time()> may be reporting the time
+as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
+
+Adjusting the system clock (either manually or by services like ntp)
+may cause problems, especially for long running programs that assume
+a monotonously increasing time (note that all platforms do not adjust
+time as gracefully as UNIX ntp does). For example in Win32 (and derived
+platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
+drift off from the system clock (and the original time()) by up to 0.5
+seconds. Time::HiRes will notice this eventually and recalibrate.
+Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
+might help in this (in case your system supports CLOCK_MONOTONIC).
+
+Some systems have APIs but not implementations: for example QNX and Haiku
+have the interval timer APIs but not the functionality.
+
+=head1 SEE ALSO
+
+Perl modules L<BSD::Resource>, L<Time::TAI64>.
+
+Your system documentation for C<clock>, C<clock_gettime>,
+C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>,
+C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>.
+
+=head1 AUTHORS
+
+D. Wegscheid <wegscd@whirlpool.com>
+R. Schertler <roderick@argon.org>
+J. Hietaniemi <jhi@iki.fi>
+G. Aas <gisle@aas.no>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
+
+Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
+All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Time/Local.pm b/Master/tlpkg/tlperl/lib/Time/Local.pm
new file mode 100644
index 00000000000..96a688d92c4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/Local.pm
@@ -0,0 +1,341 @@
+package Time::Local;
+
+require Exporter;
+use Carp;
+use Config;
+use strict;
+
+use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
+$VERSION = '1.1901_01';
+
+@ISA = qw( Exporter );
+@EXPORT = qw( timegm timelocal );
+@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;
+
+# localtime()'s limit is the year 2**31
+my $MaxDay = 365 * (2**31);
+
+# 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 - int($month / 10);
+
+ ( ( 365 * $year )
+ + int( $year / 4 )
+ - int( $year / 100 )
+ + int( $year / 400 )
+ + int( ( ( $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 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.
+
+=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@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@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@urth.org>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Time/Piece.pm b/Master/tlpkg/tlperl/lib/Time/Piece.pm
new file mode 100644
index 00000000000..a7a602fa2ca
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/Piece.pm
@@ -0,0 +1,859 @@
+# $Id: Piece.pm 82 2009-06-27 13:20:23Z matt $
+
+package Time::Piece;
+
+use strict;
+
+require Exporter;
+require DynaLoader;
+use Time::Seconds;
+use Carp;
+use Time::Local;
+#use UNIVERSAL qw(isa); # Commented out for Perl 5.12.0 by JRV to avoid a deprecation warning
+
+our @ISA = qw(Exporter DynaLoader);
+
+our @EXPORT = qw(
+ localtime
+ gmtime
+);
+
+our %EXPORT_TAGS = (
+ ':override' => 'internal',
+ );
+
+our $VERSION = '1.15_01';
+
+bootstrap Time::Piece $VERSION;
+
+my $DATE_SEP = '-';
+my $TIME_SEP = ':';
+my @MON_LIST = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+my @FULLMON_LIST = qw(January February March April May June July
+ August September October November December);
+my @DAY_LIST = qw(Sun Mon Tue Wed Thu Fri Sat);
+my @FULLDAY_LIST = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
+
+use constant 'c_sec' => 0;
+use constant 'c_min' => 1;
+use constant 'c_hour' => 2;
+use constant 'c_mday' => 3;
+use constant 'c_mon' => 4;
+use constant 'c_year' => 5;
+use constant 'c_wday' => 6;
+use constant 'c_yday' => 7;
+use constant 'c_isdst' => 8;
+use constant 'c_epoch' => 9;
+use constant 'c_islocal' => 10;
+
+sub localtime {
+ unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
+ my $class = shift;
+ my $time = shift;
+ $time = time if (!defined $time);
+ $class->_mktime($time, 1);
+}
+
+sub gmtime {
+ unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
+ my $class = shift;
+ my $time = shift;
+ $time = time if (!defined $time);
+ $class->_mktime($time, 0);
+}
+
+sub new {
+ my $class = shift;
+ my ($time) = @_;
+
+ my $self;
+
+ if (defined($time)) {
+ $self = $class->localtime($time);
+ }
+ elsif (ref($class) && $class->isa(__PACKAGE__)) {
+ $self = $class->_mktime($class->epoch, $class->[c_islocal]);
+ }
+ else {
+ $self = $class->localtime();
+ }
+
+ return bless $self, $class;
+}
+
+sub parse {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my @components;
+ if (@_ > 1) {
+ @components = @_;
+ }
+ else {
+ @components = shift =~ /(\d+)$DATE_SEP(\d+)$DATE_SEP(\d+)(?:(?:T|\s+)(\d+)$TIME_SEP(\d+)(?:$TIME_SEP(\d+)))/;
+ @components = reverse(@components[0..5]);
+ }
+ return $class->new(_strftime("%s", @components));
+}
+
+sub _mktime {
+ my ($class, $time, $islocal) = @_;
+ $class = eval { (ref $class) && (ref $class)->isa('Time::Piece') }
+ ? ref $class
+ : $class;
+ if (ref($time)) {
+ $time->[c_epoch] = undef;
+ return wantarray ? @$time : bless [@$time, $islocal], $class;
+ }
+ _tzset();
+ my @time = $islocal ?
+ CORE::localtime($time)
+ :
+ CORE::gmtime($time);
+ wantarray ? @time : bless [@time, $time, $islocal], $class;
+}
+
+my %_special_exports = (
+ localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } },
+ gmtime => sub { my $c = $_[0]; sub { $c->gmtime(@_) } },
+);
+
+sub export {
+ my ($class, $to, @methods) = @_;
+ for my $method (@methods) {
+ if (exists $_special_exports{$method}) {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$to . "::$method"} = $_special_exports{$method}->($class);
+ } else {
+ $class->SUPER::export($to, $method);
+ }
+ }
+}
+
+sub import {
+ # replace CORE::GLOBAL localtime and gmtime if required
+ my $class = shift;
+ my %params;
+ map($params{$_}++,@_,@EXPORT);
+ if (delete $params{':override'}) {
+ $class->export('CORE::GLOBAL', keys %params);
+ }
+ else {
+ $class->export((caller)[0], keys %params);
+ }
+}
+
+## Methods ##
+
+sub sec {
+ my $time = shift;
+ $time->[c_sec];
+}
+
+*second = \&sec;
+
+sub min {
+ my $time = shift;
+ $time->[c_min];
+}
+
+*minute = \&min;
+
+sub hour {
+ my $time = shift;
+ $time->[c_hour];
+}
+
+sub mday {
+ my $time = shift;
+ $time->[c_mday];
+}
+
+*day_of_month = \&mday;
+
+sub mon {
+ my $time = shift;
+ $time->[c_mon] + 1;
+}
+
+sub _mon {
+ my $time = shift;
+ $time->[c_mon];
+}
+
+sub month {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif (@MON_LIST) {
+ return $MON_LIST[$time->[c_mon]];
+ }
+ else {
+ return $time->strftime('%b');
+ }
+}
+
+*monname = \&month;
+
+sub fullmonth {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif (@FULLMON_LIST) {
+ return $FULLMON_LIST[$time->[c_mon]];
+ }
+ else {
+ return $time->strftime('%B');
+ }
+}
+
+sub year {
+ my $time = shift;
+ $time->[c_year] + 1900;
+}
+
+sub _year {
+ my $time = shift;
+ $time->[c_year];
+}
+
+sub yy {
+ my $time = shift;
+ my $res = $time->[c_year] % 100;
+ return $res > 9 ? $res : "0$res";
+}
+
+sub wday {
+ my $time = shift;
+ $time->[c_wday] + 1;
+}
+
+sub _wday {
+ my $time = shift;
+ $time->[c_wday];
+}
+
+*day_of_week = \&_wday;
+
+sub wdayname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif (@DAY_LIST) {
+ return $DAY_LIST[$time->[c_wday]];
+ }
+ else {
+ return $time->strftime('%a');
+ }
+}
+
+*day = \&wdayname;
+
+sub fullday {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif (@FULLDAY_LIST) {
+ return $FULLDAY_LIST[$time->[c_wday]];
+ }
+ else {
+ return $time->strftime('%A');
+ }
+}
+
+sub yday {
+ my $time = shift;
+ $time->[c_yday];
+}
+
+*day_of_year = \&yday;
+
+sub isdst {
+ my $time = shift;
+ $time->[c_isdst];
+}
+
+*daylight_savings = \&isdst;
+
+# Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm
+sub tzoffset {
+ my $time = shift;
+
+ return Time::Seconds->new(0) unless $time->[c_islocal];
+
+ my $epoch = $time->epoch;
+
+ my $j = sub {
+
+ my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900;
+
+ $time->_jd($y, $m, $d, $h, $n, $s);
+
+ };
+
+ # Compute floating offset in hours.
+ #
+ my $delta = 24 * (&$j(CORE::localtime $epoch) - &$j(CORE::gmtime $epoch));
+
+ # Return value in seconds rounded to nearest minute.
+ return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60 );
+}
+
+sub epoch {
+ my $time = shift;
+ if (defined($time->[c_epoch])) {
+ return $time->[c_epoch];
+ }
+ else {
+ my $epoch = $time->[c_islocal] ?
+ timelocal(@{$time}[c_sec .. c_mon], $time->[c_year]+1900)
+ :
+ timegm(@{$time}[c_sec .. c_mon], $time->[c_year]+1900);
+ $time->[c_epoch] = $epoch;
+ return $epoch;
+ }
+}
+
+sub hms {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $TIME_SEP;
+ sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]);
+}
+
+*time = \&hms;
+
+sub ymd {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]);
+}
+
+*date = \&ymd;
+
+sub mdy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year);
+}
+
+sub dmy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year);
+}
+
+sub datetime {
+ my $time = shift;
+ my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_);
+ return join($seps{T}, $time->date($seps{date}), $time->time($seps{time}));
+}
+
+
+
+# Julian Day is always calculated for UT regardless
+# of local time
+sub julian_day {
+ my $time = shift;
+ # Correct for localtime
+ $time = $time->gmtime( $time->epoch ) if $time->[c_islocal];
+
+ # Calculate the Julian day itself
+ my $jd = $time->_jd( $time->year, $time->mon, $time->mday,
+ $time->hour, $time->min, $time->sec);
+
+ return $jd;
+}
+
+# MJD is defined as JD - 2400000.5 days
+sub mjd {
+ return shift->julian_day - 2_400_000.5;
+}
+
+# Internal calculation of Julian date. Needed here so that
+# both tzoffset and mjd/jd methods can share the code
+# Algorithm from Hatcher 1984 (QJRAS 25, 53-55), and
+# Hughes et al, 1989, MNRAS, 238, 15
+# See: http://adsabs.harvard.edu/cgi-bin/nph-bib_query?bibcode=1989MNRAS.238.1529H&db_key=AST
+# for more details
+
+sub _jd {
+ my $self = shift;
+ my ($y, $m, $d, $h, $n, $s) = @_;
+
+ # Adjust input parameters according to the month
+ $y = ( $m > 2 ? $y : $y - 1);
+ $m = ( $m > 2 ? $m - 3 : $m + 9);
+
+ # Calculate the Julian Date (assuming Julian calendar)
+ my $J = int( 365.25 *( $y + 4712) )
+ + int( (30.6 * $m) + 0.5)
+ + 59
+ + $d
+ - 0.5;
+
+ # Calculate the Gregorian Correction (since we have Gregorian dates)
+ my $G = 38 - int( 0.75 * int(49+($y/100)));
+
+ # Calculate the actual Julian Date
+ my $JD = $J + $G;
+
+ # Modify to include hours/mins/secs in floating portion.
+ return $JD + ($h + ($n + $s / 60) / 60) / 24;
+}
+
+sub week {
+ my $self = shift;
+
+ my $J = $self->julian_day;
+ # Julian day is independent of time zone so add on tzoffset
+ # if we are using local time here since we want the week day
+ # to reflect the local time rather than UTC
+ $J += ($self->tzoffset/(24*3600)) if $self->[c_islocal];
+
+ # Now that we have the Julian day including fractions
+ # convert it to an integer Julian Day Number using nearest
+ # int (since the day changes at midday we oconvert all Julian
+ # dates to following midnight).
+ $J = int($J+0.5);
+
+ use integer;
+ my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461;
+ my $L = $d4 / 1460;
+ my $d1 = (($d4 - $L) % 365) + $L;
+ return $d1 / 7 + 1;
+}
+
+sub _is_leap_year {
+ my $year = shift;
+ return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0)
+ ? 1 : 0;
+}
+
+sub is_leap_year {
+ my $time = shift;
+ my $year = $time->year;
+ return _is_leap_year($year);
+}
+
+my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31);
+
+sub month_last_day {
+ my $time = shift;
+ my $year = $time->year;
+ my $_mon = $time->_mon;
+ return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0);
+}
+
+sub strftime {
+ my $time = shift;
+ my $tzname = $time->[c_islocal] ? '%Z' : 'UTC';
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S $tzname";
+ if (!defined $time->[c_wday]) {
+ if ($time->[c_islocal]) {
+ return _strftime($format, CORE::localtime($time->epoch));
+ }
+ else {
+ return _strftime($format, CORE::gmtime($time->epoch));
+ }
+ }
+ return _strftime($format, (@$time)[c_sec..c_isdst]);
+}
+
+sub strptime {
+ my $time = shift;
+ my $string = shift;
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
+ my @vals = _strptime($string, $format);
+# warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals)));
+ return scalar $time->_mktime(\@vals, (ref($time) ? $time->[c_islocal] : 0));
+}
+
+sub day_list {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @DAY_LIST;
+ if (@_) {
+ @DAY_LIST = @_;
+ }
+ return @old;
+}
+
+sub mon_list {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @MON_LIST;
+ if (@_) {
+ @MON_LIST = @_;
+ }
+ return @old;
+}
+
+sub time_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $TIME_SEP;
+ if (@_) {
+ $TIME_SEP = $_[0];
+ }
+ return $old;
+}
+
+sub date_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $DATE_SEP;
+ if (@_) {
+ $DATE_SEP = $_[0];
+ }
+ return $old;
+}
+
+use overload '""' => \&cdate,
+ 'cmp' => \&str_compare,
+ 'fallback' => undef;
+
+sub cdate {
+ my $time = shift;
+ if ($time->[c_islocal]) {
+ return scalar(CORE::localtime($time->epoch));
+ }
+ else {
+ return scalar(CORE::gmtime($time->epoch));
+ }
+}
+
+sub str_compare {
+ my ($lhs, $rhs, $reverse) = @_;
+ if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ $rhs = "$rhs";
+ }
+ return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs;
+}
+
+use overload
+ '-' => \&subtract,
+ '+' => \&add;
+
+sub subtract {
+ my $time = shift;
+ my $rhs = shift;
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+
+ if (shift)
+ {
+ # SWAPED is set (so someone tried an expression like NOTDATE - DATE).
+ # Imitate Perl's standard behavior and return the result as if the
+ # string $time resolves to was subtracted from NOTDATE. This way,
+ # classes which override this one and which have a stringify function
+ # that resolves to something that looks more like a number don't need
+ # to override this function.
+ return $rhs - "$time";
+ }
+
+ if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ return Time::Seconds->new($time->epoch - $rhs->epoch);
+ }
+ else {
+ # rhs is seconds.
+ return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]);
+ }
+}
+
+sub add {
+ my $time = shift;
+ my $rhs = shift;
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+ croak "Invalid rhs of addition: $rhs" if ref($rhs);
+
+ return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
+}
+
+use overload
+ '<=>' => \&compare;
+
+sub get_epochs {
+ my ($lhs, $rhs, $reverse) = @_;
+ if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ $rhs = $lhs->new($rhs);
+ }
+ if ($reverse) {
+ return $rhs->epoch, $lhs->epoch;
+ }
+ return $lhs->epoch, $rhs->epoch;
+}
+
+sub compare {
+ my ($lhs, $rhs) = get_epochs(@_);
+ return $lhs <=> $rhs;
+}
+
+sub add_months {
+ my ($time, $num_months) = @_;
+
+ croak("add_months requires a number of months") unless defined($num_months);
+
+ my $final_month = $time->_mon + $num_months;
+ my $num_years = 0;
+ if ($final_month > 11 || $final_month < 0) {
+ # these two ops required because we have no POSIX::floor and don't
+ # want to load POSIX.pm
+ $num_years = int($final_month / 12);
+ $num_years-- if ($final_month < 0);
+
+ $final_month = $final_month % 12;
+ }
+
+ my @vals = _mini_mktime($time->sec, $time->min, $time->hour,
+ $time->mday, $final_month, $time->year - 1900 + $num_years);
+# warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals)));
+ return scalar $time->_mktime(\@vals, $time->[c_islocal]);
+}
+
+sub add_years {
+ my ($time, $years) = @_;
+ $time->add_months($years * 12);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::Piece - Object Oriented time objects
+
+=head1 SYNOPSIS
+
+ use Time::Piece;
+
+ my $t = localtime;
+ print "Time is $t\n";
+ print "Year is ", $t->year, "\n";
+
+=head1 DESCRIPTION
+
+This module replaces the standard localtime and gmtime functions with
+implementations that return objects. It does so in a backwards
+compatible manner, so that using localtime/gmtime in the way documented
+in perlfunc will still return what you expect.
+
+The module actually implements most of an interface described by
+Larry Wall on the perl5-porters mailing list here:
+http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html
+
+=head1 USAGE
+
+After importing this module, when you use localtime or gmtime in a scalar
+context, rather than getting an ordinary scalar string representing the
+date and time, you get a Time::Piece object, whose stringification happens
+to produce the same effect as the localtime and gmtime functions. There is
+also a new() constructor provided, which is the same as localtime(), except
+when passed a Time::Piece object, in which case it's a copy constructor. The
+following methods are available on the object:
+
+ $t->sec # also available as $t->second
+ $t->min # also available as $t->minute
+ $t->hour # 24 hour
+ $t->mday # also available as $t->day_of_month
+ $t->mon # 1 = January
+ $t->_mon # 0 = January
+ $t->monname # Feb
+ $t->month # same as $t->monname
+ $t->fullmonth # February
+ $t->year # based at 0 (year 0 AD is, of course 1 BC)
+ $t->_year # year minus 1900
+ $t->yy # 2 digit year
+ $t->wday # 1 = Sunday
+ $t->_wday # 0 = Sunday
+ $t->day_of_week # 0 = Sunday
+ $t->wdayname # Tue
+ $t->day # same as wdayname
+ $t->fullday # Tuesday
+ $t->yday # also available as $t->day_of_year, 0 = Jan 01
+ $t->isdst # also available as $t->daylight_savings
+
+ $t->hms # 12:34:56
+ $t->hms(".") # 12.34.56
+ $t->time # same as $t->hms
+
+ $t->ymd # 2000-02-29
+ $t->date # same as $t->ymd
+ $t->mdy # 02-29-2000
+ $t->mdy("/") # 02/29/2000
+ $t->dmy # 29-02-2000
+ $t->dmy(".") # 29.02.2000
+ $t->datetime # 2000-02-29T12:34:56 (ISO 8601)
+ $t->cdate # Tue Feb 29 12:34:56 2000
+ "$t" # same as $t->cdate
+
+ $t->epoch # seconds since the epoch
+ $t->tzoffset # timezone offset in a Time::Seconds object
+
+ $t->julian_day # number of days since Julian period began
+ $t->mjd # modified Julian date (JD-2400000.5 days)
+
+ $t->week # week number (ISO 8601)
+
+ $t->is_leap_year # true if it its
+ $t->month_last_day # 28-31
+
+ $t->time_separator($s) # set the default separator (default ":")
+ $t->date_separator($s) # set the default separator (default "-")
+ $t->day_list(@days) # set the default weekdays
+ $t->mon_list(@days) # set the default months
+
+ $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead
+ # of the full POSIX extension)
+ $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT"
+
+ Time::Piece->strptime(STRING, FORMAT)
+ # see strptime man page. Creates a new
+ # Time::Piece object
+
+=head2 Local Locales
+
+Both wdayname (day) and monname (month) allow passing in a list to use
+to index the name of the days against. This can be useful if you need
+to implement some form of localisation without actually installing or
+using locales.
+
+ my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
+
+ my $french_day = localtime->day(@days);
+
+These settings can be overriden globally too:
+
+ Time::Piece::day_list(@days);
+
+Or for months:
+
+ Time::Piece::mon_list(@months);
+
+And locally for months:
+
+ print localtime->month(@months);
+
+=head2 Date Calculations
+
+It's possible to use simple addition and subtraction of objects:
+
+ use Time::Seconds;
+
+ my $seconds = $t1 - $t2;
+ $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
+
+The following are valid ($t1 and $t2 are Time::Piece objects):
+
+ $t1 - $t2; # returns Time::Seconds object
+ $t1 - 42; # returns Time::Piece object
+ $t1 + 533; # returns Time::Piece object
+
+However adding a Time::Piece object to another Time::Piece object
+will cause a runtime error.
+
+Note that the first of the above returns a Time::Seconds object, so
+while examining the object will print the number of seconds (because
+of the overloading), you can also get the number of minutes, hours,
+days, weeks and years in that delta, using the Time::Seconds API.
+
+In addition to adding seconds, there are two APIs for adding months and
+years:
+
+ $t->add_months(6);
+ $t->add_years(5);
+
+The months and years can be negative for subtractions. Note that there
+is some "strange" behaviour when adding and subtracting months at the
+ends of months. Generally when the resulting month is shorter than the
+starting month then the number of overlap days is added. For example
+subtracting a month from 2008-03-31 will not result in 2008-02-31 as this
+is an impossible date. Instead you will get 2008-03-02. This appears to
+be consistent with other date manipulation tools.
+
+=head2 Date Comparisons
+
+Date comparisons are also possible, using the full suite of "<", ">",
+"<=", ">=", "<=>", "==" and "!=".
+
+=head2 Date Parsing
+
+Time::Piece links to your C library's strptime() function, allowing
+you incredibly flexible date parsing routines. For example:
+
+ my $t = Time::Piece->strptime("Sun 3rd Nov, 1943",
+ "%A %drd %b, %Y");
+
+ print $t->strftime("%a, %d %b %Y");
+
+Outputs:
+
+ Wed, 03 Nov 1943
+
+(see, it's even smart enough to fix my obvious date bug)
+
+For more information see "man strptime", which should be on all unix
+systems.
+
+=head2 YYYY-MM-DDThh:mm:ss
+
+The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
+the time format to be hh:mm:ss (24 hour clock), and if combined, they
+should be concatenated with date first and with a capital 'T' in front
+of the time.
+
+=head2 Week Number
+
+The I<week number> may be an unknown concept to some readers. The ISO
+8601 standard defines that weeks begin on a Monday and week 1 of the
+year is the week that includes both January 4th and the first Thursday
+of the year. In other words, if the first Monday of January is the
+2nd, 3rd, or 4th, the preceding days of the January are part of the
+last week of the preceding year. Week numbers range from 1 to 53.
+
+=head2 Global Overriding
+
+Finally, it's possible to override localtime and gmtime everywhere, by
+including the ':override' tag in the import list:
+
+ use Time::Piece ':override';
+
+=head1 CAVEATS
+
+=head2 Setting $ENV{TZ} in Threads on Win32
+
+Note that when using perl in the default build configuration on Win32
+(specifically, when perl is built with PERL_IMPLICIT_SYS), each perl
+interpreter maintains its own copy of the environment and only the main
+interpreter will update the process environment seen by strftime.
+
+Therefore, if you make changes to $ENV{TZ} from inside a thread other than
+the main thread then those changes will not be seen by strftime if you
+subsequently call that with the %Z formatting code. You must change $ENV{TZ}
+in the main thread to have the desired effect in this case (and you must
+also call _tzset() in the main thread to register the environment change).
+
+Furthermore, remember that this caveat also applies to fork(), which is
+emulated by threads on Win32.
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl)
+
+=head1 License
+
+This module is free software, you may distribute it under the same terms
+as Perl.
+
+=head1 SEE ALSO
+
+The excellent Calendar FAQ at http://www.tondering.dk/claus/calendar.html
+
+=head1 BUGS
+
+The test harness leaves much to be desired. Patches welcome.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Time/Seconds.pm b/Master/tlpkg/tlperl/lib/Time/Seconds.pm
new file mode 100644
index 00000000000..4aac9881cb1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/Seconds.pm
@@ -0,0 +1,230 @@
+# $Id: Seconds.pm 44 2002-09-08 20:51:38Z matt $
+
+package Time::Seconds;
+use strict;
+use vars qw/@EXPORT @EXPORT_OK @ISA/;
+# use UNIVERSAL qw(isa); # Commented out for Perl 5.12.0 by JRV to avoid a deprecation warning.
+
+@ISA = 'Exporter';
+
+@EXPORT = qw(
+ ONE_MINUTE
+ ONE_HOUR
+ ONE_DAY
+ ONE_WEEK
+ ONE_MONTH
+ ONE_REAL_MONTH
+ ONE_YEAR
+ ONE_REAL_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+ );
+
+@EXPORT_OK = qw(cs_sec cs_mon);
+
+use constant ONE_MINUTE => 60;
+use constant ONE_HOUR => 3_600;
+use constant ONE_DAY => 86_400;
+use constant ONE_WEEK => 604_800;
+use constant ONE_MONTH => 2_629_744; # ONE_YEAR / 12
+use constant ONE_REAL_MONTH => '1M';
+use constant ONE_YEAR => 31_556_930; # 365.24225 days
+use constant ONE_REAL_YEAR => '1Y';
+use constant ONE_FINANCIAL_MONTH => 2_592_000; # 30 days
+use constant LEAP_YEAR => 31_622_400; # 366 * ONE_DAY
+use constant NON_LEAP_YEAR => 31_536_000; # 365 * ONE_DAY
+
+# hacks to make Time::Piece compile once again
+use constant cs_sec => 0;
+use constant cs_mon => 1;
+
+use overload
+ 'fallback' => 'undef',
+ '0+' => \&seconds,
+ '""' => \&seconds,
+ '<=>' => \&compare,
+ '+' => \&add,
+ '-' => \&subtract,
+ '-=' => \&subtract_from,
+ '+=' => \&add_to,
+ '=' => \&copy;
+
+sub new {
+ my $class = shift;
+ my ($val) = @_;
+ $val = 0 unless defined $val;
+ bless \$val, $class;
+}
+
+sub _get_ovlvals {
+ my ($lhs, $rhs, $reverse) = @_;
+ $lhs = $lhs->seconds;
+
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+ elsif (ref($rhs)) {
+ die "Can't use non Seconds object in operator overload";
+ }
+
+ if ($reverse) {
+ return $rhs, $lhs;
+ }
+
+ return $lhs, $rhs;
+}
+
+sub compare {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return $lhs <=> $rhs;
+}
+
+sub add {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs + $rhs);
+}
+
+sub add_to {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs += $rhs;
+ return $lhs;
+}
+
+sub subtract {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs - $rhs);
+}
+
+sub subtract_from {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs -= $rhs;
+ return $lhs;
+}
+
+sub copy {
+ Time::Seconds->new(${$_[0]});
+}
+
+sub seconds {
+ my $s = shift;
+ return $$s;
+}
+
+sub minutes {
+ my $s = shift;
+ return $$s / 60;
+}
+
+sub hours {
+ my $s = shift;
+ $s->minutes / 60;
+}
+
+sub days {
+ my $s = shift;
+ $s->hours / 24;
+}
+
+sub weeks {
+ my $s = shift;
+ $s->days / 7;
+}
+
+sub months {
+ my $s = shift;
+ $s->days / 30.4368541;
+}
+
+sub financial_months {
+ my $s = shift;
+ $s->days / 30;
+}
+
+sub years {
+ my $s = shift;
+ $s->days / 365.24225;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::Seconds - a simple API to convert seconds to other date values
+
+=head1 SYNOPSIS
+
+ use Time::Piece;
+ use Time::Seconds;
+
+ my $t = localtime;
+ $t += ONE_DAY;
+
+ my $t2 = localtime;
+ my $s = $t - $t2;
+
+ print "Difference is: ", $s->days, "\n";
+
+=head1 DESCRIPTION
+
+This module is part of the Time::Piece distribution. It allows the user
+to find out the number of minutes, hours, days, weeks or years in a given
+number of seconds. It is returned by Time::Piece when you delta two
+Time::Piece objects.
+
+Time::Seconds also exports the following constants:
+
+ ONE_DAY
+ ONE_WEEK
+ ONE_HOUR
+ ONE_MINUTE
+ ONE_MONTH
+ ONE_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+
+Since perl does not (yet?) support constant objects, these constants are in
+seconds only, so you cannot, for example, do this: C<print ONE_WEEK-E<gt>minutes;>
+
+=head1 METHODS
+
+The following methods are available:
+
+ my $val = Time::Seconds->new(SECONDS)
+ $val->seconds;
+ $val->minutes;
+ $val->hours;
+ $val->days;
+ $val->weeks;
+ $val->months;
+ $val->financial_months; # 30 days
+ $val->years;
+
+The methods make the assumption that there are 24 hours in a day, 7 days in
+a week, 365.24225 days in a year and 12 months in a year.
+(from The Calendar FAQ at http://www.tondering.dk/claus/calendar.html)
+
+=head1 AUTHOR
+
+Matt Sergeant, matt@sergeant.org
+
+Tobias Brox, tobiasb@tobiasb.funcom.com
+
+Bal�zs Szab� (dLux), dlux@kapu.hu
+
+=head1 LICENSE
+
+Please see Time::Piece for the license.
+
+=head1 Bugs
+
+Currently the methods aren't as efficient as they could be, for reasons of
+clarity. This is probably a bad idea.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Time/gmtime.pm b/Master/tlpkg/tlperl/lib/Time/gmtime.pm
new file mode 100644
index 00000000000..eb5b371a004
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/gmtime.pm
@@ -0,0 +1,91 @@
+package Time::gmtime;
+use strict;
+use 5.006_001;
+
+use Time::tm;
+
+our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
+BEGIN {
+ use Exporter ();
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(gmtime gmctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.03;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)}
+sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::gmtime - by-name interface to Perl's built-in gmtime() function
+
+=head1 SYNOPSIS
+
+ use Time::gmtime;
+ $gm = gmtime();
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $gm->wday() ];
+
+ use Time::gmtime qw(:FIELDS);
+ gmtime();
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ $tm_wday ];
+
+ $now = gmctime();
+
+ use Time::gmtime;
+ use File::stat;
+ $date_string = gmctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core gmtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this
+still overrides your core functions.) Access these fields as variables
+named with a preceding C<tm_> in front their method names. Thus,
+C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields.
+
+The gmctime() function provides a way of getting at the
+scalar sense of the original CORE::gmtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Time/localtime.pm b/Master/tlpkg/tlperl/lib/Time/localtime.pm
new file mode 100644
index 00000000000..c3d9fb36085
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/localtime.pm
@@ -0,0 +1,86 @@
+package Time::localtime;
+use strict;
+use 5.006_001;
+
+use Time::tm;
+
+our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
+BEGIN {
+ use Exporter ();
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(localtime ctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.02;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)}
+sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::localtime - by-name interface to Perl's built-in localtime() function
+
+=head1 SYNOPSIS
+
+ use Time::localtime;
+ printf "Year is %d\n", localtime->year() + 1900;
+
+ $now = ctime();
+
+ use Time::localtime;
+ use File::stat;
+ $date_string = ctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core localtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as
+variables named with a preceding C<tm_> in front their method names.
+Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import
+the fields.
+
+The ctime() function provides a way of getting at the
+scalar sense of the original CORE::localtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/Time/tm.pm b/Master/tlpkg/tlperl/lib/Time/tm.pm
new file mode 100644
index 00000000000..2c308ebb411
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Time/tm.pm
@@ -0,0 +1,33 @@
+package Time::tm;
+use strict;
+
+our $VERSION = '1.00';
+
+use Class::Struct qw(struct);
+struct('Time::tm' => [
+ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
+]);
+
+1;
+__END__
+
+=head1 NAME
+
+Time::tm - internal object used by Time::gmtime and Time::localtime
+
+=head1 SYNOPSIS
+
+Don't use this module directly.
+
+=head1 DESCRIPTION
+
+This module is used internally as a base class by Time::localtime And
+Time::gmtime functions. It creates a Time::tm struct object which is
+addressable just like's C's tm structure from F<time.h>; namely with sec,
+min, hour, mday, mon, year, wday, yday, and isdst.
+
+This class is an internal interface only.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/User/grent.pm b/Master/tlpkg/tlperl/lib/User/grent.pm
new file mode 100644
index 00000000000..ce6ee5ea447
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/User/grent.pm
@@ -0,0 +1,95 @@
+package User::grent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getgrent getgrgid getgrnam getgr);
+ @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members);
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::grent' => [
+ name => '$',
+ passwd => '$',
+ gid => '$',
+ members => '@',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $gob = new();
+ ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2];
+ @gr_members = @{$gob->[3]} = split ' ', $_[3];
+ return $gob;
+}
+
+sub getgrent ( ) { populate(CORE::getgrent()) }
+sub getgrnam ($) { populate(CORE::getgrnam(shift)) }
+sub getgrgid ($) { populate(CORE::getgrgid(shift)) }
+sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam }
+
+1;
+__END__
+
+=head1 NAME
+
+User::grent - by-name interface to Perl's built-in getgr*() functions
+
+=head1 SYNOPSIS
+
+ use User::grent;
+ $gr = getgrgid(0) or die "No group zero";
+ if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ use User::grent qw(:FIELDS);
+ getgrgid(0) or die "No group zero";
+ if ( $gr_name eq 'wheel' && @gr_members > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ $gr = getgr($whoever);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getgrent(), getgruid(),
+and getgrnam() functions, replacing them with versions that return
+"User::grent" objects. This object has methods that return the similarly
+named structure field name from the C's passwd structure from F<grp.h>;
+namely name, passwd, gid, and members (not mem). The first three
+return scalars, the last an array reference.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds
+to $gr_gid if you import the fields. Array references are available as
+regular array variables, so C<@{ $group_obj-E<gt>members() }> would be
+simply @gr_members.
+
+The getpw() function is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/Master/tlpkg/tlperl/lib/User/pwent.pm b/Master/tlpkg/tlperl/lib/User/pwent.pm
new file mode 100644
index 00000000000..91d23bd3f68
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/User/pwent.pm
@@ -0,0 +1,298 @@
+package User::pwent;
+
+use 5.006;
+our $VERSION = '1.00';
+
+use strict;
+use warnings;
+
+use Config;
+use Carp;
+
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getpwent getpwuid getpwnam getpw);
+ @EXPORT_OK = qw(
+ pw_has
+
+ $pw_name $pw_passwd $pw_uid $pw_gid
+ $pw_gecos $pw_dir $pw_shell
+ $pw_expire $pw_change $pw_class
+ $pw_age
+ $pw_quota $pw_comment
+ $pw_expire
+
+ );
+ %EXPORT_TAGS = (
+ FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ],
+ ALL => [ @EXPORT, @EXPORT_OK ],
+ );
+}
+use vars grep /^\$pw_/, @EXPORT_OK;
+
+#
+# XXX: these mean somebody hacked this module's source
+# without understanding the underlying assumptions.
+#
+my $IE = "[INTERNAL ERROR]";
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::pwent' => [
+ name => '$', # pwent[0]
+ passwd => '$', # pwent[1]
+ uid => '$', # pwent[2]
+ gid => '$', # pwent[3]
+
+ # you'll only have one/none of these three
+ change => '$', # pwent[4]
+ age => '$', # pwent[4]
+ quota => '$', # pwent[4]
+
+ # you'll only have one/none of these two
+ comment => '$', # pwent[5]
+ class => '$', # pwent[5]
+
+ # you might not have this one
+ gecos => '$', # pwent[6]
+
+ dir => '$', # pwent[7]
+ shell => '$', # pwent[8]
+
+ # you might not have this one
+ expire => '$', # pwent[9]
+
+];
+
+
+# init our groks hash to be true if the built platform knew how
+# to do each struct pwd field that perl can ever under any circumstances
+# know about. we do not use /^pw_?/, but just the tails.
+sub _feature_init {
+ our %Groks; # whether build system knew how to do this feature
+ for my $feep ( qw{
+ pwage pwchange pwclass pwcomment
+ pwexpire pwgecos pwpasswd pwquota
+ }
+ )
+ {
+ my $short = $feep =~ /^pw(.*)/
+ ? $1
+ : do {
+ # not cluck, as we know we called ourselves,
+ # and a confession is probably imminent anyway
+ warn("$IE $feep is a funny struct pwd field");
+ $feep;
+ };
+
+ exists $Config{ "d_" . $feep }
+ || confess("$IE Configure doesn't d_$feep");
+ $Groks{$short} = defined $Config{ "d_" . $feep };
+ }
+ # assume that any that are left are always there
+ for my $feep (grep /^\$pw_/s, @EXPORT_OK) {
+ $feep =~ /^\$pw_(.*)/;
+ $Groks{$1} = 1 unless defined $Groks{$1};
+ }
+}
+
+# With arguments, reports whether one or more fields are all implemented
+# in the build machine's struct pwd pw_*. May be whitespace separated.
+# We do not use /^pw_?/, just the tails.
+#
+# Without arguments, returns the list of fields implemented on build
+# machine, space separated in scalar context.
+#
+# Takes exception to being asked whether this machine's struct pwd has
+# a field that Perl never knows how to provide under any circumstances.
+# If the module does this idiocy to itself, the explosion is noisier.
+#
+sub pw_has {
+ our %Groks; # whether build system knew how to do this feature
+ my $cando = 1;
+ my $sploder = caller() ne __PACKAGE__
+ ? \&croak
+ : sub { confess("$IE @_") };
+ if (@_ == 0) {
+ my @valid = sort grep { $Groks{$_} } keys %Groks;
+ return wantarray ? @valid : "@valid";
+ }
+ for my $feep (map { split } @_) {
+ defined $Groks{$feep}
+ || $sploder->("$feep is never a valid struct pwd field");
+ $cando &&= $Groks{$feep};
+ }
+ return $cando;
+}
+
+sub _populate (@) {
+ return unless @_;
+ my $pwob = new();
+
+ # Any that haven't been pw_had are assumed on "all" platforms of
+ # course, this may not be so, but you can't get here otherwise,
+ # since the underlying core call already took exception to your
+ # impudence.
+
+ $pw_name = $pwob->name ( $_[0] );
+ $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd");
+ $pw_uid = $pwob->uid ( $_[2] );
+ $pw_gid = $pwob->gid ( $_[3] );
+
+ if (pw_has("change")) {
+ $pw_change = $pwob->change ( $_[4] );
+ }
+ elsif (pw_has("age")) {
+ $pw_age = $pwob->age ( $_[4] );
+ }
+ elsif (pw_has("quota")) {
+ $pw_quota = $pwob->quota ( $_[4] );
+ }
+
+ if (pw_has("class")) {
+ $pw_class = $pwob->class ( $_[5] );
+ }
+ elsif (pw_has("comment")) {
+ $pw_comment = $pwob->comment( $_[5] );
+ }
+
+ $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos");
+
+ $pw_dir = $pwob->dir ( $_[7] );
+ $pw_shell = $pwob->shell ( $_[8] );
+
+ $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire");
+
+ return $pwob;
+}
+
+sub getpwent ( ) { _populate(CORE::getpwent()) }
+sub getpwnam ($) { _populate(CORE::getpwnam(shift)) }
+sub getpwuid ($) { _populate(CORE::getpwuid(shift)) }
+sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam }
+
+_feature_init();
+
+1;
+__END__
+
+=head1 NAME
+
+User::pwent - by-name interface to Perl's built-in getpw*() functions
+
+=head1 SYNOPSIS
+
+ use User::pwent;
+ $pw = getpwnam('daemon') || die "No daemon user";
+ if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) {
+ print "gid 1 on root dir";
+ }
+
+ $real_shell = $pw->shell || '/bin/sh';
+
+ for (($fullname, $office, $workphone, $homephone) =
+ split /\s*,\s*/, $pw->gecos)
+ {
+ s/&/ucfirst(lc($pw->name))/ge;
+ }
+
+ use User::pwent qw(:FIELDS);
+ getpwnam('daemon') || die "No daemon user";
+ if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) {
+ print "gid 1 on root dir";
+ }
+
+ $pw = getpw($whoever);
+
+ use User::pwent qw/:DEFAULT pw_has/;
+ if (pw_has(qw[gecos expire quota])) { .... }
+ if (pw_has("name uid gid passwd")) { .... }
+ print "Your struct pwd has: ", scalar pw_has(), "\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getpwent(), getpwuid(),
+and getpwnam() functions, replacing them with versions that return
+C<User::pwent> objects. This object has methods that return the
+similarly named structure field name from the C's passwd structure
+from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>,
+C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>,
+C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>,
+C<gecos>, and C<shell> fields are tainted when running in taint mode.
+
+You may also import all the structure fields directly into your
+namespace as regular variables using the :FIELDS import tag. (Note
+that this still overrides your core functions.) Access these fields
+as variables named with a preceding C<pw_> in front their method
+names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell
+if you import the fields.
+
+The getpw() function is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides, pass the
+C<use> an empty import list, and then access function functions
+with their full qualified names. The built-ins are always still
+available via the C<CORE::> pseudo-package.
+
+=head2 System Specifics
+
+Perl believes that no machine ever has more than one of C<change>,
+C<age>, or C<quota> implemented, nor more than one of either
+C<comment> or C<class>. Some machines do not support C<expire>,
+C<gecos>, or allegedly, C<passwd>. You may call these methods
+no matter what machine you're on, but they return C<undef> if
+unimplemented.
+
+You may ask whether one of these was implemented on the system Perl
+was built on by asking the importable C<pw_has> function about them.
+This function returns true if all parameters are supported fields
+on the build platform, false if one or more were not, and raises
+an exception if you asked about a field that Perl never knows how
+to provide. Parameters may be in a space-separated string, or as
+separate arguments. If you pass no parameters, the function returns
+the list of C<struct pwd> fields supported by your build platform's
+C library, as a list in list context, or a space-separated string
+in scalar context. Note that just because your C library had
+a field doesn't necessarily mean that it's fully implemented on
+that system.
+
+Interpretation of the C<gecos> field varies between systems, but
+traditionally holds 4 comma-separated fields containing the user's
+full name, office location, work phone number, and home phone number.
+An C<&> in the gecos field should be replaced by the user's properly
+capitalized login C<name>. The C<shell> field, if blank, must be
+assumed to be F</bin/sh>. Perl does not do this for you. The
+C<passwd> is one-way hashed garble, not clear text, and may not be
+unhashed save by brute-force guessing. Secure systems use more a
+more secure hashing than DES. On systems supporting shadow password
+systems, Perl automatically returns the shadow password entry when
+called by a suitably empowered user, even if your underlying
+vendor-provided C library was too short-sighted to realize it should
+do this.
+
+See passwd(5) and getpwent(3) for details.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
+
+=head1 HISTORY
+
+=over 4
+
+=item March 18th, 2000
+
+Reworked internals to support better interface to dodgey fields
+than normal Perl function provides. Added pw_has() field. Improved
+documentation.
+
+=back
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm
new file mode 100644
index 00000000000..365ce6b46c5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API.pm
@@ -0,0 +1,778 @@
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
+# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
+#
+# $Id: API.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+package Win32::API;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( $DEBUG );
+$DEBUG = 0;
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API::Type;
+use Win32::API::Struct;
+use File::Basename ();
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+$VERSION = '0.59';
+
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ my $hdll;
+ my $self = {};
+
+ if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+ # need to convert $dll to win32 path
+ # isn't there an API for this?
+ my $newdll = `cygpath -w "$dll"`;
+ chomp $newdll;
+ DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
+ $dll = $newdll;
+ }
+
+ #### avoid loading a library more than once
+ if(exists($Libraries{$dll})) {
+ DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
+ $hdll = $Libraries{$dll};
+ } else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n";
+ $hdll = Win32::API::LoadLibrary($dll);
+# $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if(!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
+ return undef;
+ }
+
+ #### determine if we have a prototype or not
+ if( (not defined $in) and (not defined $out) ) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) = parse_prototype( $proc );
+ return undef unless $proc;
+ $self->{proto} = 1;
+ } else {
+ $self->{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ }
+ $self->{out} = type_to_num($out);
+ $self->{cdecl} = calltype_to_num($callconvention);
+ }
+
+ #### first try to import the function of given name...
+ my $hproc = Win32::API::GetProcAddress($hdll, $proc);
+
+ #### ...then try appending either A or W (for ASCII or Unicode)
+ if(!$hproc) {
+ my $tproc = $proc;
+ $tproc .= (IsUnicode() ? "W" : "A");
+ # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
+ $hproc = Win32::API::GetProcAddress($hdll, $tproc);
+ }
+
+ #### ...if all that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+ $self->{proc} = $hproc;
+
+ #### keep track of the imported function
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+
+ DEBUG "Object blessed!\n";
+
+ #### cast the spell
+ bless($self, $class);
+ return $self;
+}
+
+sub Import {
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0;
+ my $P = (caller)[0];
+ eval qq(
+ sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
+ );
+ return $@ ? 0 : 1;
+}
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my($self) = @_;
+
+ #### decrease this library's procedures reference count
+ $Procedures{$self->{dllname}}--;
+
+ #### once it reaches 0, free it
+ if($Procedures{$self->{dllname}} == 0) {
+ DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+# Convert calling convention string (_cdecl|__stdcall)
+# to an integer (1|0). Unknown counts as __stdcall
+#
+sub calltype_to_num {
+ my $type = shift;
+
+ if (!$type || $type eq "__stdcall") {
+ return 0;
+ }
+ elsif ($type eq "_cdecl") {
+ return 1;
+ }
+ else {
+ warn "unknown calling convention: '$type'";
+ return 0;
+ }
+}
+
+sub type_to_num {
+ my $type = shift;
+ my $out = shift;
+ my $num;
+
+ if( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ ) {
+ $num = 1;
+ } elsif($type eq 'P'
+ or $type eq 'p'
+ ) {
+ $num = 2;
+ } elsif($type eq 'I'
+ or $type eq 'i'
+ ) {
+ $num = 3;
+ } elsif($type eq 'f'
+ or $type eq 'F'
+ ) {
+ $num = 4;
+ } elsif($type eq 'D'
+ or $type eq 'd'
+ ) {
+ $num = 5;
+ } elsif($type eq 'c'
+ or $type eq 'C'
+ ) {
+ $num = 6;
+ } else {
+ $num = 0;
+ }
+ unless(defined $out) {
+ if( $type eq 's'
+ or $type eq 'S'
+ ) {
+ $num = 51;
+ } elsif($type eq 'b'
+ or $type eq 'B'
+ ) {
+ $num = 22;
+ } elsif($type eq 'k'
+ or $type eq 'K'
+ ) {
+ $num = 101;
+ }
+ }
+ return $num;
+}
+
+sub parse_prototype {
+ my($proto) = @_;
+
+ my @in_params = ();
+ my @in_types = ();
+ if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $callconvention= $2;
+ my $proc = $3;
+ my $params = $4;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my($type, $name);
+ if($param =~ /(\S+)\s+(\S+)/) {
+ ($type, $name) = ($1, $2);
+ }
+
+ if(Win32::API::Type::is_known($type)) {
+ if(Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num('P');
+ push(@in_params, type_to_num('P'));
+ } else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num( Win32::API::Type->packing( $type ) );
+ push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ }
+ } elsif( Win32::API::Struct::is_known( $type ) ) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'S', type_to_num('S');
+ push(@in_params, type_to_num('S'));
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n";
+
+
+
+ if(Win32::API::Type::is_known($ret)) {
+ if(Win32::API::Type::is_pointer($ret)) {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num('P');
+ return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) );
+ } else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num( Win32::API::Type->packing( $ret ) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)), calltype_to_num($callconvention) );
+ }
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) );
+ }
+
+ } else {
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll, 'int sum_integers(int a, int b)',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with parameter list
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll', 'sum_integers', 'II', 'I',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with Import
+
+ use Win32::API;
+ Win32::API->Import(
+ 'mydll', 'int sum_integers(int a, int b)',
+ );
+ $return = sum_integers(3, 2);
+
+
+=for LATER-UNIMPLEMENTED
+ #### or
+ use Win32::API mydll => 'int sum_integers(int a, int b)';
+ $return = sum_integers(3, 2);
+
+
+=head1 ABSTRACT
+
+With this module you can import and call arbitrary functions
+from Win32's Dynamic Link Libraries (DLL), without having
+to write an XS extension. Note, however, that this module
+can't do everything. In fact, parameters input and output is
+limited to simpler cases.
+
+A regular B<XS> extension is always safer and faster anyway.
+
+The current version of Win32::API is always available at your
+nearest CPAN mirror:
+
+ http://search.cpan.org/dist/Win32-API/
+
+A short example of how you can use this module (it just gets the PID of
+the current process, eg. same as Perl's internal C<$$>):
+
+ use Win32::API;
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+=head1 DESCRIPTION
+
+To use this module put the following line at the beginning of your script:
+
+ use Win32::API;
+
+You can now use the C<new()> function of the Win32::API module to create a
+new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
+C<Call()> method on this object to perform a call to the imported API
+(see L<CALLING AN IMPORTED FUNCTION>).
+
+Starting from version 0.40, you can also avoid creating a Win32::API object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. The details of the API definitions are the same,
+just the call is different:
+
+ my $GetCurrentProcessId = Win32::API->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns 1 on success and 0 on failure (in which case you
+can check the content of C<$^E>).
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file
+with the C<new()> function. This will create a Perl object that contains the
+reference to that function, which you can later C<Call()>.
+
+What you need to know is the prototype of the function you're going to import
+(eg. the definition of the function expressed in C syntax).
+
+Starting from version 0.40, there are 2 different approaches for this step:
+(the preferred) one uses the prototype directly, while the other (now deprecated)
+one uses Win32::API's internal representation for parameters.
+
+=head2 IMPORTING A FUNCTION BY PROTOTYPE
+
+You need to pass 2 parameters:
+
+=over 4
+
+=item 1.
+
+The name of the library from which you want to import the function.
+
+=item 2.
+
+The C prototype of the function.
+
+=back
+
+When calling a function imported with a prototype, if you pass an
+undefined Perl scalar to one of its arguments, it will be
+automatically turned into a C C<NULL> value.
+
+See L<Win32::API::Type> for a list of the known parameter types and
+L<Win32::API::Struct> for information on how to define a structure.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass 4 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The name of the function (as exported by the library).
+
+=item 3.
+The number and types of the arguments the function expects as input.
+
+=item 4.
+The type of the value returned by the function.
+
+=item 5.
+And optionally you can specify the calling convention, this defaults to
+'__stdcall', alternatively you can specify '_cdecl'.
+
+=back
+
+To better explain their meaning, let's suppose that we
+want to import and call the Win32 API C<GetTempPath()>.
+This function is defined in C as:
+
+ DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
+
+This is documented in the B<Win32 SDK Reference>; you can look
+for it on the Microsoft's WWW site, or in your C compiler's
+documentation, if you own one.
+
+=over 4
+
+=item B<1.>
+
+The first parameter is the name of the library file that
+exports this function; our function resides in the F<KERNEL32.DLL>
+system file.
+
+When specifying this name as parameter, the F<.DLL> extension
+is implicit, and if no path is given, the file is searched through
+a couple of directories, including:
+
+=over 4
+
+=item 1. The directory from which the application loaded.
+
+=item 2. The current directory.
+
+=item 3. The Windows system directory (eg. c:\windows\system or system32).
+
+=item 4. The Windows directory (eg. c:\windows).
+
+=item 5. The directories that are listed in the PATH environment variable.
+
+=back
+
+So, you don't have to write F<C:\windows\system\kernel32.dll>;
+only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API('kernel32', ...
+
+=item B<2.>
+
+Now for the second parameter: the name of the function.
+It must be written exactly as it is exported
+by the library (case is significant here).
+If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
+command on the DLL file to see the function it exports.
+Remember that you can only import functions from 32 bit DLLs:
+in Quick View, the file's characteristics should report
+somewhere "32 bit word machine"; as a rule of thumb,
+when you see that all the exported functions are in upper case,
+the DLL is a 16 bit one and you can't use it.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL.
+
+Also note that many Win32 APIs are exported twice, with the addition of
+a final B<A> or B<W> to their name, for - respectively - the ASCII
+and the Unicode version.
+When a function name is not found, Win32::API will actually append
+an B<A> to the name and try again; if the extension is built on a
+Unicode system, then it will try with the B<W> instead.
+So our function name will be:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<3.>
+
+The third parameter, the input parameter list, specifies how many
+arguments the function wants, and their types. It can be passed as
+a single string, in which each character represents one parameter,
+or as a list reference. The following forms are valid:
+
+ "abcd"
+ [a, b, c, d]
+ \@LIST
+
+But those are not:
+
+ (a, b, c, d)
+ @LIST
+
+The number of characters, or elements in the list, specifies the number
+of parameters, and each character or element specifies the type of an
+argument; allowed types are:
+
+=over 4
+
+=item C<I>:
+value is an integer (int)
+
+=item C<N>:
+value is a number (long)
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<C>:
+value is a char (char)
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+
+=item C<S>:
+value is a Win32::API::Struct object (see below)
+
+=item C<K>:
+value is a Win32::API::Callback object (see L<Win32::API::Callback>)
+
+=back
+
+Our function needs two parameters: a number (C<DWORD>) and a pointer to a
+string (C<LPSTR>):
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
+
+=item B<4.>
+
+The fourth and final parameter is the type of the value returned by the
+function. It can be one of the types seen above, plus another type named B<V>
+(for C<void>), used for functions that do not return a value.
+In our example the value returned by GetTempPath() is a C<DWORD>, so
+our return type will be B<N>:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+
+Now the line is complete, and the GetTempPath() API is ready to be used
+in Perl. Before calling it, you should test that $GetTempPath is
+C<defined>, otherwise either the function or the library could not be
+loaded; in this case, C<$!> will be set to the error message reported
+by Windows.
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $!\n";
+ }
+
+=back
+
+=head2 CALLING AN IMPORTED FUNCTION
+
+To effectively make a call to an imported function you must use the
+Call() method on the Win32::API object you created.
+Continuing with the example from the previous paragraph,
+the GetTempPath() API can be called using the method:
+
+ $GetTempPath->Call(...
+
+Of course, parameters have to be passed as defined in the import phase.
+In particular, if the number of parameters does not match (in the example,
+if GetTempPath() is called with more or less than two parameters),
+Perl will C<croak> an error message and C<die>.
+
+The two parameters needed here are the length of the buffer
+that will hold the returned temporary path, and a pointer to the
+buffer itself.
+For numerical parameters, you can use either a constant expression
+or a variable, while B<for pointers you must use a variable name> (no
+Perl references, just a plain variable name).
+Also note that B<memory must be allocated before calling the function>,
+just like in C.
+For example, to pass a buffer of 80 characters to GetTempPath(),
+it must be initialized before with:
+
+ $lpBuffer = " " x 80;
+
+This allocates a string of 80 characters. If you don't do so, you'll
+probably get C<Runtime exception> errors, and generally nothing will
+work. The call should therefore include:
+
+ $lpBuffer = " " x 80;
+ $GetTempPath->Call(80, $lpBuffer);
+
+And the result will be stored in the $lpBuffer variable.
+Note that you don't need to pass a reference to the variable
+(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
+by the function.
+
+A little problem here is that Perl does not trim the variable,
+so $lpBuffer will still contain 80 characters in return; the exceeding
+characters will be spaces, because we said C<" " x 80>.
+
+In this case we're lucky enough, because the value returned by
+the GetTempPath() function is the length of the string, so to get
+the actual temporary path we can write:
+
+ $lpBuffer = " " x 80;
+ $return = $GetTempPath->Call(80, $lpBuffer);
+ $TempPath = substr($lpBuffer, 0, $return);
+
+If you don't know the length of the string, you can usually
+cut it at the C<\0> (ASCII zero) character, which is the string
+delimiter in C:
+
+ $TempPath = ((split(/\0/, $lpBuffer))[0];
+ # or
+ $lpBuffer =~ s/\0.*$//;
+
+=head2 USING STRUCTURES
+
+Starting from version 0.40, Win32::API comes with a support package
+named Win32::API::Struct. The package is loaded automatically with
+Win32::API, so you don't need to use it explicitly.
+
+With this module you can conveniently define structures and use
+them as parameters to Win32::API functions. A short example follows:
+
+
+ # the 'POINT' structure is defined in C as:
+ # typedef struct {
+ # LONG x;
+ # LONG y;
+ # } POINT;
+
+
+ #### define the structure
+ Win32::API::Struct->typedef( POINT => qw{
+ LONG x;
+ LONG y;
+ });
+
+ #### import an API that uses this structure
+ Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
+
+ #### create a 'POINT' object
+ my $pt = Win32::API::Struct->new('POINT');
+
+ #### call the function passing our structure object
+ GetCursorPos($pt);
+
+ #### and now, access its members
+ print "The cursor is at: $pt->{x}, $pt->{y}\n";
+
+Note that this works only when the function wants a
+B<pointer to a structure>: as you can see, our structure is named
+'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
+the beginning of the structure name when feeding it to a Win32::API
+call.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the C<Win32::API::Struct> facility,
+you can still use the low-level approach to use structures:
+
+=over 4
+
+=item 1.
+
+you have to pack() the required elements in a variable:
+
+ $lpPoint = pack('LL', 0, 0); # store two LONGs
+
+=item 2.
+
+to access the values stored in a structure, unpack() it as required:
+
+ ($x, $y) = unpack('LL', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=head1 LICENSE
+
+To finally clarify this, C<Win32::API> is OSI-approved free software;
+you can redistribute it and/or modify it under the same terms as Perl
+itself.
+
+See L<http://dev.perl.org/licenses/artistic.html>
+
+=head1 CREDITS
+
+All the credits go to Andrea Frosini for the neat assembler trick
+that makes this thing work. I've also used some work by Dave Roth
+for the prototyping stuff. A big thank you also to Gurusamy Sarathy
+for his unvaluable help in XS development, and to all the Perl
+community for being what it is.
+
+Cosimo also wants to personally thank everyone that contributed
+to Win32::API with complaints, emails, patches, RT bug reports
+and so on.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
new file mode 100644
index 00000000000..df15786591b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
@@ -0,0 +1,174 @@
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Callback - Perl Win32 API Import Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Callback.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+package Win32::API::Callback;
+
+$VERSION = '0.59';
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+sub DEBUG {
+ if ($WIN32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API;
+use Win32::API::Type;
+use Win32::API::Struct;
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ $!=0;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API::Callback;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $proc, $in, $out) = @_;
+ my %self = ();
+
+ # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+
+ $self{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ }
+ $self{out} = Win32::API::type_to_num($out);
+ $self{sub} = $proc;
+ my $self = bless \%self, $class;
+
+ DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
+ my $hproc = CallbackCreate($self);
+
+ DEBUG "(PM)Callback::new: hproc=$hproc\n";
+
+ #### ...if that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ return undef;
+ }
+
+ #### ok, let's stuff the object
+ $self->{code} = $hproc;
+ $self->{sub} = $proc;
+
+ #### cast the spell
+ return $self;
+}
+
+sub MakeStruct {
+ my($self, $n, $addr) = @_;
+ DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
+ my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
+ $struct->FromMemory($addr);
+ return $struct;
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Callback - Callback support for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+ use Win32::API::Callback;
+
+ my $callback = Win32::API::Callback->new(
+ sub { my($a, $b) = @_; return $a+$b; },
+ "NN", "N",
+ );
+
+ Win32::API->Import(
+ 'mydll', 'two_integers_cb', 'KNN', 'N',
+ );
+
+ $sum = two_integers_cb( $callback, 3, 2 );
+
+
+=head1 FOREWORDS
+
+=over 4
+
+=item *
+Support for this module is B<highly experimental> at this point.
+
+=item *
+I won't be surprised if it doesn't work for you.
+
+=item *
+Feedback is very appreciated.
+
+=item *
+Documentation is in the work. Either see the SYNOPSIS above
+or the samples in the F<samples> directory.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
new file mode 100644
index 00000000000..9f706671a77
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm
@@ -0,0 +1,532 @@
+package Win32::API::Struct;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Struct - Perl Win32 API struct Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Struct.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
+#######################################################################
+
+$VERSION = '0.50';
+
+use Win32::API::Type;
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+my %Known = ();
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub typedef {
+ my $class = shift;
+ my $struct = shift;
+ my($type, $name);
+ my $self = {
+ align => undef,
+ typedef => [],
+ };
+ while(defined($type = shift)) {
+ $name = shift;
+ $name =~ s/;$//;
+ push( @{ $self->{typedef} }, [ recognize($type, $name) ] );
+ }
+
+ $Known{$struct} = $self;
+ return 1;
+}
+
+
+sub recognize {
+ my($type, $name) = @_;
+ my($size, $packing);
+ if(exists $Known{$type}) {
+ $packing = ">";
+ return $name, $packing, $type;
+ } else {
+ $packing = Win32::API::Type::packing($type);
+ return undef unless defined $packing;
+ if($name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $packing."*".$size;
+ }
+ DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n";
+ return $name, $packing, $type;
+ }
+}
+
+sub new {
+ my $class = shift;
+ my($type, $name);
+ my $self = {
+ typedef => [],
+ };
+ if($#_ == 0) {
+ if(exists $Known{$_[0]}) {
+ DEBUG "(PM)Struct::new: got '$_[0]'\n";
+ $self->{typedef} = $Known{$_[0]}->{typedef};
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if($packing eq '>') {
+ $self->{$name} = Win32::API::Struct->new($type);
+ }
+ }
+ $self->{__typedef__} = $_[0];
+ } else {
+ carp "Unknown Win32::API::Struct '$_[0]'";
+ return undef;
+ }
+ } else {
+ while(defined($type = shift)) {
+ $name = shift;
+ # print "new: found member $name ($type)\n";
+ if(not exists $Win32::API::Type::Known{$type}) {
+ warn "Unknown Win32::API::Struct type '$type'";
+ return undef;
+ } else {
+ push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] );
+ }
+ }
+ }
+ return bless $self;
+}
+
+sub members {
+ my $self = shift;
+ return map {$_->[0]} @{ $self->{typedef} };
+}
+
+sub sizeof {
+ my $self = shift;
+ my $size = 0;
+ my $align = 0;
+ my $first = undef;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ $size += $self->{$name}->sizeof();
+ # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align;
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ $size += Win32::API::Type::sizeof($type) * $1;
+ $first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ } else {
+ $size += Win32::API::Type::sizeof($type);
+ $first = Win32::API::Type::sizeof($type) unless defined $first;
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ }
+ }
+ }
+ DEBUG "(PM)Struct::sizeof first=$first align=$align\n";
+ #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ #return $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align;
+ if(defined $align and $align > 0) {
+ return scalar(@{ $self->{typedef} }) * $align;
+ } else {
+ return $size;
+ }
+ return $size;
+}
+
+sub align {
+ my $self = shift;
+ my $align = shift;
+
+ if(not defined $align) {
+ return $self->{align} unless $self->{align} eq 'auto';
+ $align = 0;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ #### ????
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ #### ????
+ } else {
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ }
+ }
+ }
+ return $align;
+ } else {
+ $self->{align} = $align;
+
+ }
+}
+
+sub getPack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my @recipients = ();
+
+ my $align = $self->align();
+
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack();
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
+
+ $packing .= $subpacking;
+ push(@items, @$subitems);
+ push(@recipients, @$subrecipients);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "a$size";
+ }
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
+
+ if($type eq 'p') {
+ $type = "L";
+ push(@items, Win32::API::PointerTo($self->{$name}));
+ } else {
+ push(@items, $self->{$name});
+ }
+ $packing .= $type;
+
+ if($Win32::API::Type::PackSize{$type} < $align) {
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@recipients, $self);
+ }
+ }
+ DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n";
+ return($packing, [@items], [@recipients]);
+}
+
+
+sub Pack {
+ my $self = shift;
+ my($packing, $items, $recipients) = $self->getPack();
+ DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n";
+ $self->{buffer} = pack($packing, @$items);
+ if(DEBUG) {
+ for my $i (0..$self->sizeof-1) {
+ printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
+ }
+ }
+ $self->{buffer_recipients} = $recipients
+}
+
+sub getUnpack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my $align = $self->align();
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, @subitems) = $self->{$name}->getUnpack();
+
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
+ $packing .= $subpacking;
+
+
+ push(@items, @subitems);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "Z$size";
+ }
+
+ #if($type eq 'p') {
+ # $packing .= 'Z*';
+ # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n";
+ #} else {
+ $packing .= $type;
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
+ #}
+ if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) {
+ DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n",
+ $type, $Win32::API::Type::PackSize{$type}, $align
+ ;
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@items, $name);
+ }
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n";
+ return($packing, @items);
+}
+
+sub Unpack {
+ my $self = shift;
+ my($packing, @items) = $self->getUnpack();
+ my @itemvalue = unpack($packing, $self->{buffer});
+ DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n";
+ foreach my $i (0..$#items) {
+ my $recipient = $self->{buffer_recipients}->[$i];
+ DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
+ $recipient->{__typedef__},
+ $items[$i],
+ $itemvalue[$i],
+ $itemvalue[$i],
+ ;
+ $recipient->{$items[$i]} = $itemvalue[$i];
+ DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n";
+ }
+}
+
+sub FromMemory {
+ my($self, $addr) = @_;
+ DEBUG "(PM)Struct::FromMemory: doing Pack\n";
+ $self->Pack();
+ DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof;
+ $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof );
+ $self->Unpack();
+ DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
+ DEBUG "(PM)Struct::FromMemory: structure is now:\n";
+ $self->Dump() if DEBUG;
+ DEBUG "\n";
+}
+
+sub Dump {
+ my $self = shift;
+ my $prefix = shift;
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if( ref($self->{$name}) ) {
+ $self->{$name}->Dump($name);
+ } else {
+ printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
+ }
+ }
+}
+
+
+sub is_known {
+ my $name = shift;
+ if(exists $Known{ $name }) {
+ return 1;
+ } else {
+ if($name =~ s/^LP//) {
+ return exists $Known{ $name };
+ }
+ return 0;
+ }
+}
+
+sub TIEHASH {
+ return Win32::API::Struct::new(@_);
+}
+
+sub EXISTS {
+
+}
+
+sub FETCH {
+ my $self = shift;
+ my $key = shift;
+
+ if($key eq 'sizeof') {
+ return $self->sizeof;
+ }
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ return $self->{$key};
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub STORE {
+ my $self = shift;
+ my($key, $val) = @_;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ $self->{$key} = $val;
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ return $members[0];
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ my $key = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ for my $i (0..$#members-1) {
+ return $members[$i+1] if $members[$i] eq $key;
+ }
+ return undef;
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Struct - C struct support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Struct->typedef( 'POINT', qw(
+ LONG x;
+ LONG y;
+ ));
+
+ my $Point = Win32::API::Struct->new( 'POINT' );
+ $Point->{x} = 1024;
+ $Point->{y} = 768;
+
+ #### alternatively
+
+ tie %Point, 'Win32::API::Struct', 'POINT';
+ $Point{x} = 1024;
+ $Point{y} = 768;
+
+
+=head1 ABSTRACT
+
+This module enables you to define C structs for use with
+Win32::API.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. The main methods are C<typedef> and
+C<new>, which are documented below.
+
+=over 4
+
+=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...>
+
+This method defines a structure named C<NAME>. The definition consists
+of types and member names, just like in C. In fact, most of the
+times you can cut the C definition for a structure and paste it
+verbatim to your script, enclosing it in a C<qw()> block. The
+function takes care of removing the semicolon after the member
+name.
+
+The synopsis example could be written like this:
+
+ Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y');
+
+But it could also be written like this (note the indirect object
+syntax), which is pretty cool:
+
+ typedef Win32::API::Struct POINT => qw{
+ LONG x;
+ LONG y;
+ };
+
+Also note that C<typedef> automatically defines an 'LPNAME' type,
+which holds a pointer to your structure. In the example above,
+'LPPOINT' is also defined and can be used in a call to a
+Win32::API (in fact, this is what you're really going to use when
+doing API calls).
+
+=item C<new NAME>
+
+This creates a structure (a Win32::API::Struct object) of the
+type C<NAME> (it must have been defined with C<typedef>). In Perl,
+when you create a structure, all the members are undefined. But
+when you use that structure in C (eg. a Win32::API call), you
+can safely assume that they will be treated as zero (or NULL).
+
+=item C<sizeof>
+
+This returns the size, in bytes, of the structure. Acts just like
+the C function of the same name. It is particularly useful for
+structures that need a member to be initialized to the structure's
+own size.
+
+=item C<align [SIZE]>
+
+Sets or returns the structure alignment (eg. how the structure is
+stored in memory). This is a very advanced option, and you normally
+don't need to mess with it.
+All structures in the Win32 Platform SDK should work without it.
+But if you define your own structure, you may need to give it an
+explicit alignment. In most cases, passing a C<SIZE> of 'auto'
+should keep the world happy.
+
+=back
+
+=head2 THE C<tie> INTERFACE
+
+Instead of creating an object with the C<new> method, you can
+tie a hash, which will hold the desired structure, using the
+C<tie> builtin function:
+
+ tie %structure, Win32::API::Struct => 'NAME';
+
+The differences between the tied and non-tied approaches are:
+
+=over 4
+
+=item *
+with tied structures, you can access members directly as
+hash lookups, eg.
+
+ # tied # non-tied
+ $Point{x} vs. $Point->{x}
+
+=item *
+with tied structures, when you try to fetch or store a
+member that is not part of the structure, it will result
+in a warning, eg.
+
+ print $Point{z};
+ # this will warn: 'z' is not a member of Win32::API::Struct POINT
+
+=item *
+when you pass a tied structure as a Win32::API parameter,
+remember to backslash it, eg.
+
+ # tied # non-tied
+ GetCursorPos( \%Point ) vs. GetCursorPos( $Point )
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm
new file mode 100644
index 00000000000..0b21ced6927
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm
@@ -0,0 +1,111 @@
+#
+# Win32::API::Test - Test helper package for Win32::API
+#
+# Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Test.pm 438 2008-10-02 22:51:55Z cosimo.streppone $
+
+package Win32::API::Test;
+
+sub compiler_name () {
+ use Config;
+ my $cc = $Config{ccname};
+ if($cc eq 'cl' || $cc eq 'cl.exe')
+ {
+ $cc = 'cl';
+ }
+ return($cc);
+}
+
+sub compiler_version () {
+ use Config;
+ my $ver = $Config{ccversion} || 0;
+ if( $ver =~ /^(\d+\.\d+)/ )
+ {
+ $ver = 0 + $1;
+ }
+ return($ver);
+}
+
+#
+# Run the compiler and get version from there...
+# User might be running a compiler different from
+# that used to build perl.
+# For example, Cosimo does. For testing, of course.
+#
+sub compiler_version_from_shell () {
+ my $cc = compiler_name();
+ my $ver;
+ # MSVC
+ if($cc eq 'cl')
+ {
+ my @ver = `$cc 2>&1`; # Interesting output in STDERR
+ $ver = join('',@ver);
+ #print 'VER:'.$ver.':'."\n";
+ if($ver =~ /Version (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # GCC
+ elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' )
+ {
+ $ver = join('', `$cc --version`);
+ if($ver =~ /gcc.*(\d[\d+]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # Borland C
+ elsif($cc eq 'bcc32' || $cc eq 'bcc')
+ {
+ $ver = join('', `$cc 2>&1`);
+ if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ return($ver);
+}
+
+sub find_test_dll () {
+ require File::Spec;
+ my $dll_name = $_[0];
+ my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll);
+ while(my $path = shift @paths)
+ {
+ $dll = File::Spec->catfile($path, $dll_name);
+ return $dll if -s $dll;
+ }
+ return(undef);
+}
+
+1;
+
+__END__
+
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Test - Test helper package for Win32::API
+
+=head1 SYNOPSIS
+
+ my $test_dll = Win32::API::Test::find_test_dll('API_test.dll');
+
+Check the t/*.t test scripts for more details.
+
+=head1 DESCRIPTION
+
+Simple package to hold Win32::API test suite helper functions.
+No more, no less.
+
+=head1 AUTHOR
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm
new file mode 100644
index 00000000000..48f0ce1a32f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm
@@ -0,0 +1,453 @@
+package Win32::API::Type;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Type - Perl Win32 API type definitions
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Type.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+$VERSION = '0.59';
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( %Known %PackSize %Modifier %Pointer );
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+%Known = ();
+%PackSize = ();
+%Modifier = ();
+%Pointer = ();
+
+# Initialize data structures at startup.
+# Aldo wants to keep the <DATA> approach.
+#
+my $section = 'nothing';
+foreach (<DATA>) {
+ next if /^\s*#/ or /^\s*$/;
+ chomp;
+ if( /\[(.+)\]/) {
+ $section = $1;
+ next;
+ }
+ if($section eq 'TYPE') {
+ my($name, $packing) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
+ $Known{$name} = $packing;
+ } elsif($section eq 'PACKSIZE') {
+ my($packing, $size) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
+ $PackSize{$packing} = $size;
+ } elsif($section eq 'MODIFIER') {
+ my($modifier, $mapto) = split(/\s+/, $_, 2);
+ my %maps = ();
+ foreach my $item (split(/\s+/, $mapto)) {
+ my($k, $v) = split(/=/, $item);
+ $maps{$k} = $v;
+ }
+ # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n";
+ $Modifier{$modifier} = { %maps };
+ } elsif($section eq 'POINTER') {
+ my($pointer, $pointto) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
+ $Pointer{$pointer} = $pointto;
+ }
+}
+close(DATA);
+
+sub new {
+ my $class = shift;
+ my($type) = @_;
+ my $packing = packing($type);
+ my $size = sizeof($type);
+ my $self = {
+ type => $type,
+ packing => $packing,
+ size => $size,
+ };
+ return bless $self;
+}
+
+sub typedef {
+ my $class = shift;
+ my($name, $type) = @_;
+ my $packing = packing($type, $name);
+ DEBUG "(PM)Type::typedef: packing='$packing'\n";
+ my $size = sizeof($type);
+ $Known{$name} = $packing;
+ return 1;
+}
+
+
+sub is_known {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ return defined packing($type);
+ }
+}
+
+sub sizeof {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return $self->{size};
+ } else {
+ my $packing = packing($type);
+ if($packing =~ /(\w)\*(\d+)/) {
+ return $PackSize{ $1 } * $2;
+ } else {
+ return $PackSize{ $packing };
+ }
+ }
+}
+
+sub packing {
+ # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
+ my $self = shift;
+ my $is_pointer = 0;
+ if(ref($self) =~ /Win32::API::Type/) {
+ # DEBUG "(PM)Type::packing: got an object\n";
+ return $self->{packing};
+ }
+ my $type = ($self eq 'Win32::API::Type') ? shift : $self;
+ my $name = shift;
+
+ # DEBUG "(PM)Type::packing: got '$type', '$name'\n";
+ my($modifier, $size, $packing);
+ if(exists $Pointer{$type}) {
+ # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n";
+ $type = $Pointer{$type};
+ $is_pointer = 1;
+ } elsif($type =~ /(\w+)\s+(\w+)/) {
+ $modifier = $1;
+ $type = $2;
+ # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n";
+ }
+
+ $type =~ s/\*$//;
+
+ if(exists $Known{$type}) {
+ if(defined $name and $name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $Known{$type}[0]."*".$size;
+ # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n";
+ } else {
+ $packing = $Known{$type};
+ if($is_pointer and $packing eq 'c') {
+ $packing = "p";
+ }
+ # DEBUG "(PM)Type::packing: simple packing: '$packing'\n";
+ }
+ if(defined $modifier and exists $Modifier{$modifier}->{$type}) {
+ # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
+ $packing = $Modifier{$modifier}->{$type};
+ }
+ return $packing;
+ } else {
+ # DEBUG "(PM)Type::packing: NOT FOUND\n";
+ return undef;
+ }
+}
+
+
+sub is_pointer {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ if($type =~ /\*$/) {
+ return 1;
+ } else {
+ return exists $Pointer{$type};
+ }
+ }
+}
+
+sub Pack {
+ my ($type, $arg) = @_;
+
+ my $pack_type = packing($type);
+
+ if($pack_type eq 'p') {
+ $pack_type = 'Z*';
+ }
+
+ $arg = pack($pack_type, $arg);
+
+ return $arg;
+}
+
+sub Unpack {
+ my ($type, $arg) = @_;
+
+ my $pack_type = packing($type);
+
+ if($pack_type eq 'p') {
+ DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n";
+ $pack_type = 'Z*';
+ }
+
+ DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n";
+ $arg = unpack($pack_type, $arg);
+ DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n";
+ return $arg;
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Type - C type support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Type->typedef( 'my_number', 'LONG' );
+
+
+=head1 ABSTRACT
+
+This module is a support package for Win32::API that implements
+C types for the import with prototype functionality.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. These are the methods of this package:
+
+=over 4
+
+=item C<typedef NAME, TYPE>
+
+This method defines a new type named C<NAME>. This actually just
+creates an alias for the already-defined type C<TYPE>, which you
+can use as a parameter in a Win32::API call.
+
+=item C<sizeof TYPE>
+
+This returns the size, in bytes, of C<TYPE>. Acts just like
+the C function of the same name.
+
+=item C<is_known TYPE>
+
+Returns true if C<TYPE> is known by Win32::API::Type, false
+otherwise.
+
+=back
+
+=head2 SUPPORTED TYPES
+
+This module should recognize all the types defined in the
+Win32 Platform SDK header files.
+Please see the source for this module, in the C<__DATA__> section,
+for the full list.
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
+
+__DATA__
+
+[TYPE]
+ATOM s
+BOOL L
+BOOLEAN c
+BYTE C
+CHAR c
+COLORREF L
+DWORD L
+DWORD32 L
+DWORD64 Q
+FLOAT f
+HACCEL L
+HANDLE L
+HBITMAP L
+HBRUSH L
+HCOLORSPACE L
+HCONV L
+HCONVLIST L
+HCURSOR L
+HDC L
+HDDEDATA L
+HDESK L
+HDROP L
+HDWP L
+HENHMETAFILE L
+HFILE L
+HFONT L
+HGDIOBJ L
+HGLOBAL L
+HHOOK L
+HICON L
+HIMC L
+HINSTANCE L
+HKEY L
+HKL L
+HLOCAL L
+HMENU L
+HMETAFILE L
+HMODULE L
+HPALETTE L
+HPEN L
+HRGN L
+HRSRC L
+HSZ L
+HWINSTA L
+HWND L
+INT i
+INT32 i
+INT64 q
+LANGID s
+LCID L
+LCSCSTYPE L
+LCSGAMUTMATCH L
+LCTYPE L
+LONG l
+LONG32 l
+LONG64 q
+LONGLONG q
+LPARAM L
+LRESULT L
+REGSAM L
+SC_HANDLE L
+SC_LOCK L
+SERVICE_STATUS_HANDLE L
+SHORT s
+SIZE_T L
+SSIZE_T L
+TBYTE c
+TCHAR C
+UCHAR C
+UINT I
+UINT_PTR L
+UINT32 I
+UINT64 Q
+ULONG L
+ULONG32 L
+ULONG64 Q
+ULONGLONG Q
+USHORT S
+WCHAR S
+WORD S
+WPARAM L
+VOID c
+
+int i
+long l
+float f
+double d
+char c
+
+#CRITICAL_SECTION 24 -- a structure
+#LUID ? 8 -- a structure
+#VOID 0
+#CONST 4
+#FILE_SEGMENT_ELEMENT 8 -- a structure
+
+[PACKSIZE]
+c 1
+C 1
+d 8
+f 4
+i 4
+I 4
+l 4
+L 4
+q 8
+Q 8
+s 2
+S 2
+p 4
+
+[MODIFIER]
+unsigned int=I long=L short=S char=C
+
+[POINTER]
+INT_PTR INT
+LPBOOL BOOL
+LPBYTE BYTE
+LPCOLORREF COLORREF
+LPCSTR CHAR
+#LPCTSTR CHAR or WCHAR
+LPCTSTR CHAR
+LPCVOID any
+LPCWSTR WCHAR
+LPDOUBLE double
+LPDWORD DWORD
+LPHANDLE HANDLE
+LPINT INT
+LPLONG LONG
+LPSTR CHAR
+#LPTSTR CHAR or WCHAR
+LPTSTR CHAR
+LPVOID VOID
+LPWORD WORD
+LPWSTR WCHAR
+
+PBOOL BOOL
+PBOOLEAN BOOL
+PBYTE BYTE
+PCHAR CHAR
+PCSTR CSTR
+PCWCH CWCH
+PCWSTR CWSTR
+PDWORD DWORD
+PFLOAT FLOAT
+PHANDLE HANDLE
+PHKEY HKEY
+PINT INT
+PLCID LCID
+PLONG LONG
+PSHORT SHORT
+PSTR CHAR
+#PTBYTE TBYTE --
+#PTCHAR TCHAR --
+#PTSTR CHAR or WCHAR
+PTSTR CHAR
+PUCHAR UCHAR
+PUINT UINT
+PULONG ULONG
+PUSHORT USHORT
+PVOID VOID
+PWCHAR WCHAR
+PWORD WORD
+PWSTR WCHAR
diff --git a/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm b/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm
new file mode 100644
index 00000000000..00200dead1f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm
@@ -0,0 +1,752 @@
+package Win32::Shortcut;
+#######################################################################
+#
+# Win32::Shortcut - Perl Module for Shell Link Interface
+# ^^^^^^^^^^^^^^^
+# This module creates an object oriented interface to the Win32
+# Shell Links (IShellLink interface).
+#
+#######################################################################
+
+$VERSION = "0.07";
+
+require Exporter;
+require DynaLoader;
+
+@ISA= qw( Exporter DynaLoader );
+@EXPORT = qw(
+ SW_SHOWMAXIMIZED
+ SW_SHOWMINNOACTIVE
+ SW_SHOWNORMAL
+);
+
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $!;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ my(undef, $file, $line) = caller;
+ die "Win32::Shortcut::$constname is not defined, used at $file line $line.";
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# PUBLIC METHODS
+#
+
+#========
+sub new {
+#========
+ my($class, $file) = @_;
+ my($ilink, $ifile) = _Instance();
+ return unless $ilink && $ifile;
+
+ my $self = bless {
+ ilink => $ilink,
+ ifile => $ifile,
+ File => "",
+ Path => "",
+ Arguments => "",
+ WorkingDirectory => "",
+ Description => "",
+ ShowCmd => 0,
+ Hotkey => 0,
+ IconLocation => "",
+ IconNumber => 0,
+ };
+
+
+ if ($file) {
+ $self->{File} = $file;
+ $self->Load($file);
+ }
+
+ return $self;
+}
+
+#=========
+sub Load {
+#=========
+ my($self, $file) = @_;
+ return undef unless ref($self);
+
+ my $result = _Load($self->{'ilink'}, $self->{'ifile'}, $file);
+
+ if ($result) {
+
+ # fill the properties of $self
+ $self->{'File'} = $file;
+ $self->{'Path'} = _GetPath($self->{'ilink'}, $self->{'ifile'},0);
+ $self->{'ShortPath'} = _GetPath($self->{'ilink'}, $self->{'ifile'},1);
+ $self->{'Arguments'} = _GetArguments($self->{'ilink'}, $self->{'ifile'});
+ $self->{'WorkingDirectory'} = _GetWorkingDirectory($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Description'} = _GetDescription($self->{'ilink'}, $self->{'ifile'});
+ $self->{'ShowCmd'} = _GetShowCmd($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Hotkey'} = _GetHotkey($self->{'ilink'}, $self->{'ifile'});
+ ($self->{'IconLocation'},
+ $self->{'IconNumber'}) = _GetIconLocation($self->{'ilink'}, $self->{'ifile'});
+ }
+ return $result;
+}
+
+
+#========
+sub Set {
+#========
+ my($self, $path, $arguments, $dir, $description, $show, $hotkey,
+ $iconlocation, $iconnumber) = @_;
+ return undef unless ref($self);
+
+ $self->{'Path'} = $path;
+ $self->{'Arguments'} = $arguments;
+ $self->{'WorkingDirectory'} = $dir;
+ $self->{'Description'} = $description;
+ $self->{'ShowCmd'} = $show;
+ $self->{'Hotkey'} = $hotkey;
+ $self->{'IconLocation'} = $iconlocation;
+ $self->{'IconNumber'} = $iconnumber;
+ return 1;
+}
+
+
+#=========
+sub Save {
+#=========
+ my($self, $file) = @_;
+ return unless ref($self);
+
+ $file = $self->{'File'} unless $file;
+ return unless $file;
+
+ require Win32 unless defined &Win32::GetFullPathName;
+ $file = Win32::GetFullPathName($file);
+
+ _SetPath($self->{'ilink'}, $self->{'ifile'}, $self->{'Path'});
+ _SetArguments($self->{'ilink'}, $self->{'ifile'}, $self->{'Arguments'});
+ _SetWorkingDirectory($self->{'ilink'}, $self->{'ifile'}, $self->{'WorkingDirectory'});
+ _SetDescription($self->{'ilink'}, $self->{'ifile'}, $self->{'Description'});
+ _SetShowCmd($self->{'ilink'}, $self->{'ifile'}, $self->{'ShowCmd'});
+ _SetHotkey($self->{'ilink'}, $self->{'ifile'}, $self->{'Hotkey'});
+ _SetIconLocation($self->{'ilink'}, $self->{'ifile'},
+ $self->{'IconLocation'}, $self->{'IconNumber'});
+
+ my $result = _Save($self->{'ilink'}, $self->{'ifile'}, $file);
+ if ($result) {
+ $self->{'File'} = $file unless $self->{'File'};
+ }
+ return $result;
+}
+
+#============
+sub Resolve {
+#============
+ my($self, $flags) = @_;
+ return undef unless ref($self);
+ $flags = 1 unless defined($flags);
+ my $result = _Resolve($self->{'ilink'}, $self->{'ifile'}, $flags);
+ return $result;
+}
+
+
+#==========
+sub Close {
+#==========
+ my($self) = @_;
+ return undef unless ref($self);
+
+ my $result = _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ return $result;
+}
+
+#=========
+sub Path {
+#=========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Path'};
+ } else {
+ $self->{'Path'} = $value;
+ }
+ return $self->{'Path'};
+}
+
+#==============
+sub ShortPath {
+#==============
+ my($self) = @_;
+ return undef unless ref($self);
+ return $self->{'ShortPath'};
+}
+
+#==============
+sub Arguments {
+#==============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Arguments'};
+ } else {
+ $self->{'Arguments'} = $value;
+ }
+ return $self->{'Arguments'};
+}
+
+#=====================
+sub WorkingDirectory {
+#=====================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'WorkingDirectory'};
+ } else {
+ $self->{'WorkingDirectory'} = $value;
+ }
+ return $self->{'WorkingDirectory'};
+}
+
+
+#================
+sub Description {
+#================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Description'};
+ } else {
+ $self->{'Description'} = $value;
+ }
+ return $self->{'Description'};
+}
+
+#============
+sub ShowCmd {
+#============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'ShowCmd'};
+ } else {
+ $self->{'ShowCmd'} = $value;
+ }
+ return $self->{'ShowCmd'};
+}
+
+#===========
+sub Hotkey {
+#===========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Hotkey'};
+ } else {
+ $self->{'Hotkey'} = $value;
+ }
+ return $self->{'Hotkey'};
+}
+
+#=================
+sub IconLocation {
+#=================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconLocation'};
+ } else {
+ $self->{'IconLocation'} = $value;
+ }
+ return $self->{'IconLocation'};
+}
+
+#===============
+sub IconNumber {
+#===============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconNumber'};
+ } else {
+ $self->{'IconNumber'} = $value;
+ }
+ return $self->{'IconNumber'};
+}
+
+#============
+sub Version {
+#============
+ # [dada] to get rid of the "used only once" warning...
+ return $VERSION;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+
+#============
+sub DESTROY {
+#============
+ my($self) = @_;
+
+ if (not $self->{'released'}) {
+ _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ }
+}
+
+bootstrap Win32::Shortcut;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::Shortcut - Perl Module to deal with Windows Shortcuts
+
+=head1 SYNOPSIS
+
+This module implements the Win32 IShellLink Interface to allow
+management of shortcut files from Perl.
+
+ use Win32::Shortcut;
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\Directory\\Target.exe";
+ $LINK->{'Description'} = "Target executable";
+ $LINK->Save("Target.lnk");
+ $LINK->Close();
+
+=head1 REFERENCE
+
+=head2 General Usage
+
+To use this module, first add the following line at the beginning of
+your script:
+
+ use Win32::Shortcut;
+
+Then, use this command to create a shortcut object:
+
+ $LINK = Win32::Shortcut->new();
+
+This function will create a C<$LINK> object on which you can apply the
+Methods and Properties explained later.
+
+The object is not yet a shortcut file; it is just the definition of a
+shortcut. Basically, you can do 2 things:
+
+=over
+
+=item 1. Load a shortcut file into the object.
+
+=item 2. Save the object into a shortcut file.
+
+=back
+
+For the rest, the object can be accessed as it were a normal
+associative array reference. It has the following keys (here referred
+as properties):
+
+ $LINK->{'File'}
+ $LINK->{'Path'} $LINK->Path()
+ $LINK->{'ShortPath'}
+ $LINK->{'WorkingDirectory'} $LINK->WorkingDirectory()
+ $LINK->{'Arguments'} $LINK->Arguments()
+ $LINK->{'Description'} $LINK->Description()
+ $LINK->{'ShowCmd'} $LINK->ShowCmd()
+ $LINK->{'Hotkey'} $LINK->Hotkey()
+ $LINK->{'IconLocation'} $LINK->IconLocation()
+ $LINK->{'IconNumber'} $LINK->IconNumber()
+
+Thus, assuming you have a shortcut file named C<test.lnk> in your
+current directory, this simple script will tell you where this shortcut
+points to:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ print "Shortcut to: $LINK->{'Path'} $LINK->{'Arguments'} \n";
+ $LINK->Close();
+
+But you can also modify its values:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ $LINK->{'Path'} =~ s/C:/D:/i; # move the target from C: to D:
+ $LINK->{'ShowCmd'} = SW_NORMAL; # runs in a normal window
+
+and then you can save your changes to the shortcut file with this
+command:
+
+ $LINK->Save();
+ $LINK->Close();
+
+or you can save it with another name, creating a new shortcut file:
+
+ $LINK->Save("test2.lnk");
+ $LINK->Close();
+
+Finally, you can create a completely new shortcut:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\PERL5\\BIN\\PERL.EXE";
+ $LINK->{'Arguments'} = "-v";
+ $LINK->{'WorkingDirectory'} = "C:\PERL5\\BIN";
+ $LINK->{'Description'} = "Prints out the version of Perl";
+ $LINK->{'ShowCmd'} = SW_SHOWMAXIMIZED;
+ $LINK->Save("Perl Version Info.lnk");
+ $LINK->Close();
+
+Note also that in the examples above the two lines:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+
+can be collapsed to:
+
+ $LINK = Win32::Shortcut->new("test.lnk");
+
+
+=head2 Methods
+
+=over
+
+=item B<Close>
+
+Closes a shortcut object. Note that it is not "strictly" required to
+close the objects you created, since the Win32::Shortcut objects are
+automatically closed when the program ends (or when you elsehow destroy
+such an object).
+
+Note also that a shortcut is not automatically saved when it is closed,
+even if you modified it. You have to call Save in order to apply
+modifications to a shortcut file.
+
+Example:
+
+ $LINK->Close();
+
+=item B<Load> I<file>
+
+Loads the content of the shortcut file named I<file> in a shortcut
+object and fill the properties of the object with its values. Will
+return B<undef> on errors, or a true value if everything was
+successful.
+
+Example:
+
+ $LINK->Load("test.lnk") or print "test.lnk not found!";
+
+ print join("\n", $LINK->Path,
+ $LINK->ShortPath,
+ $LINK->Arguments,
+ $LINK->WorkingDirectory,
+ $LINK->Description,
+ $LINK->ShowCmd,
+ $LINK->Hotkey,
+ $LINK->IconLocation,
+ $LINK->IconNumber);
+ }
+
+=item B<new Win32::Shortcut> I<[file]>
+
+Creates a new shortcut object. If a filename is passed in I<file>,
+automatically Loads this file also. Returns the object created or
+B<undef> on errors.
+
+Example:
+
+ $LINK = Win32::Shortcut->new();
+
+ $RegEdit = Win32::Shortcut->new("Registry Editor.lnk");
+ die "File not found" if not $RegEdit;
+
+=item B<Resolve> I<[flag]>
+
+Attempts to automatically resolve a shortcut and returns the resolved
+path, or B<undef> on errors; in case no resolution was made, the path
+is returned unchanged. Note that the path is automatically updated in
+the Path property of the shortcut.
+
+By default this method acts quietly, but if you pass a value of 0
+(zero) in the I<flag> parameter, it will eventually post a dialog box
+prompting the user for more information.
+
+Example:
+
+ # if the target doesn't exist...
+ if(! -f $LINK->Path) {
+ # save the actual target for comparison
+ $oldpath = $LINK->Path;
+
+ # try to resolve it (with dialog box)
+ $newpath = $LINK->Resolve(0);
+
+ die "Not resolved..." if $newpath == $oldpath;
+ }
+
+=item B<Save> I<[file]>
+
+Saves the content of the shortcut object into the file named I<file>.
+If I<file> is omitted, it is taken from the File property of the object
+(which, if not changed, is the name of the last Loaded file).
+
+If no file was loaded and the File property doesn't contain a valid
+filename, the method will return B<undef>, which will also be returned
+on errors. A true value will be returned if everything was successful.
+
+Example:
+
+ $LINK->Save();
+ $LINK->Save("Copy of " . $LINK->{'File'});
+
+=item B<Set> I<path, arguments, workingdirectory, description, showcmd,
+hotkey, iconlocation, iconnumber>
+
+Sets all the properties of the shortcut object with a single command.
+This method is supplied for convenience only, you can also set those
+values changing the values of the properties.
+
+Example:
+
+ $LINK->Set("C:\\PERL5\\BIN\\PERL.EXE",
+ "-v",
+ "C:\\PERL5\\BIN",
+ "Prints out the version of Perl",
+ SW_SHOWMAXIMIZED,
+ hex('0x0337'),
+ "C:\\WINDOWS\\SYSTEM\\COOL.DLL",
+ 1);
+
+ # it is the same of...
+ $LINK->Path("C:\\PERL5\\BIN\\PERL.EXE");
+ $LINK->Arguments("-v");
+ $LINK->WorkingDirectory("C:\\PERL5\\BIN");
+ $LINK->Description("Prints out the version of Perl");
+ $LINK->ShowCmd(SW_SHOWMAXIMIZED);
+ $LINK->Hotkey(hex('0x0337'));
+ $LINK->IconLocation("C:\\WINDOWS\\SYSTEM\\COOL.DLL");
+ $LINK->IconNumber(1);
+
+=back
+
+=head2 Properties
+
+The properties of a shortcut object can be accessed as:
+
+ $OBJECT->{'property'}
+
+Eg., assuming that you have created a shortcut object with:
+
+ $LINK=new Win32::Shortcut();
+
+you can for example see its description with:
+
+ print $LINK->{'Description'};
+
+You can of course also set it:
+
+ $LINK->{'Description'}="This is a description";
+
+From version 0.02, those properties have also a corresponding method
+(subroutine), so you can write the 2 lines above using this syntax too:
+
+ print $LINK->Description;
+ $LINK->Description("This is a description");
+
+The properties of a shortcut reflect the content of the Shortcut
+Properties Dialog Box, which can be obtained by clicking the third
+mouse button on a shortcut file in the Windows 95 (or NT 4.0) Explorer
+and choosing "Properties" (well, I hope you already knew :).
+
+The fields corresponding to the single properties are marked in B<bold>
+in the following list.
+
+=over
+
+=item B<Arguments>
+
+The arguments associated with the shell link object. They will be
+passed to the targeted program (see Path) when it gets executed. In
+fact, joined with Path, this parameter forms the "B<Target>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<Description>
+
+An optional description given to the shortcut. Seems to be missing in
+the Shortcut Properties Dialog Box (not yet implemented?).
+
+=item B<File>
+
+The filename of the shortcut file opened with Load, and/or the filename
+under which the shortcut will be saved with Save (if the I<file>
+argument is not specified).
+
+=item B<Hotkey>
+
+The hotkey associated to the shortcut, in the form of a 2-byte number
+of which the first byte identifies the modifiers (Ctrl, Alt, Shift...
+but I didn't find out how it works) and the second is the ASCII code of
+the character key. Correspond to the "B<Shortcut key>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<IconLocation>
+
+The file that contain the icon for the shortcut. Seems actually to
+always return nothing (YMMV, I hope...).
+
+=item B<IconNumber>
+
+The number of the icon for the shortcut in the file pointed by
+IconLocation, in case more that one icon is contained in that file (I
+suppose this, documentation isn't so clear at this point).
+
+=item B<Path>
+
+The target of the shortcut. This is (joined with Arguments) the content
+of the "B<Target>" field in a Shortcut Properties Dialog Box.
+
+=item B<ShortPath>
+
+Same as Path, but expressed in a DOS-readable format (8.3 characters
+filenames). It is available as read-only (well, you can change it, but
+it has no effect on the shortcut; change Path instead) once you Load a
+shortcut file.
+
+=item B<ShowCmd>
+
+The condition of the window in which the program will be executed (can
+be Normal, Minimized or Maximized). Correspond to the "B<Run>" field of
+a Shortcut Properties Dialog Box.
+
+Allowed values are:
+
+B<Value> B<Meaning> B<Constant>
+
+ 1 Normal Window SW_SHOWNORMAL
+ 3 Maximized SW_SHOWMAXIMIZED
+ 7 Minimized SW_SHOWMINNOACTIVE
+
+Any other value (theoretically should) result in a Normal Window
+display.
+
+=item B<WorkingDirectory>
+
+The directory in which the targeted program will be executed.
+Correspond to the "B<Start in>" field of a Shortcut Properties Dialog
+Box.
+
+=back
+
+=head2 Constants
+
+The following constants are exported in the main namespace of your
+script using Win32::Shortcut:
+
+=over
+
+=item * SW_SHOWNORMAL
+
+=item * SW_SHOWMAXIMIZED
+
+=item * SW_SHOWMINNOACTIVE
+
+=back
+
+Those constants are the allowed values for the ShowCmd property.
+
+
+
+=head1 VERSION HISTORY
+
+B<0.03 (07 Apr 1997)>
+
+=over
+
+=item * The PLL file now comes in 2 versions, one for Perl version
+5.001 (build 110) and one for Perl version 5.003 (build 300 and higher,
+EXCEPT 304).
+
+=item * Added an installation program which will automatically copy the
+right files in the right place.
+
+=back
+
+B<0.02 (21 Jan 1997)>
+
+=over
+
+=item * Added methods matching properties to reduce typing overhead
+(eg. Alt-123 and 125...).
+
+=back
+
+B<0.01 (15 Jan 1997)>
+
+=over
+
+=item *
+
+First public release.
+
+=item *
+
+Added "Set" and "Resolve" and the properties "Hotkey", "IconLocation"
+and "IconNumber".
+
+=back
+
+B<0.01a (10 Jan 1997)>
+
+=over
+
+=item *
+
+First implementation of the IShellLink interface (wow, it works!); can
+"Load", "Save", and modify properties of shortcut files.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini L<dada@perl.it>
+
+=head1 CREDITS
+
+Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
+Perl-Win32-Users community.
+
+=head1 DISCLAIMER
+
+I<This program is FREE; you can redistribute, modify, disassemble, or
+even reverse engineer this software at your will. Keep in mind,
+however, that NOTHING IS GUARANTEED to work and everything you do is AT
+YOUR OWN RISK - I will not take responsability for any damage, loss of
+money and/or health that may arise from the use of this program!>
+
+This is distributed under the terms of Larry Wall's Artistic License.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm
new file mode 100644
index 00000000000..19f9fdf4ae5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm
@@ -0,0 +1,3809 @@
+package Win32::TieRegistry;
+
+# Win32/TieRegistry.pm -- Perl module to easily use a Registry
+# (on Win32 systems so far).
+# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
+
+#
+# Skip to "=head" line for user documentation.
+#
+use 5.006;
+use strict;
+use Carp;
+use Tie::Hash ();
+
+use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
+BEGIN {
+ $PACK = 'Win32::TieRegistry';
+ $VERSION = '0.26';
+ @ISA = 'Tie::Hash';
+}
+
+# Required other modules:
+use Win32API::Registry 0.24 qw( :KEY_ :HKEY_ :REG_ );
+
+#Optional other modules:
+use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar );
+
+if ( eval { require Win32::WinError } ) {
+ $_NoMoreItems = Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0);
+ $_FileNotFound = Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0);
+ $_TooSmall = Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0);
+ $_MoreData = Win32::WinError::constant("ERROR_MORE_DATA",0);
+} else {
+ $_NoMoreItems = "^No more data";
+ $_FileNotFound = "cannot find the file";
+ $_TooSmall = " data area passed to ";
+ $_MoreData = "^more data is avail";
+}
+if ( $_SetDualVar = eval { require SetDualVar } ) {
+ import SetDualVar;
+}
+
+#Implementation details:
+# When opened:
+# HANDLE long; actual handle value
+# MACHINE string; name of remote machine ("" if local)
+# PATH list ref; machine-relative full path for this key:
+# ["LMachine","System","Disk"]
+# ["HKEY_LOCAL_MACHINE","System","Disk"]
+# DELIM char; delimiter used to separate subkeys (def="\\")
+# OS_DELIM char; always "\\" for Win32
+# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc.
+# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map
+# FLAGS int; bits to control certain options
+# Often:
+# VALUES ref to list of value names (data/type never cached)
+# SUBKEYS ref to list of subkey names
+# SUBCLASSES ref to list of subkey classes
+# SUBTIMES ref to list of subkey write times
+# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's
+# MEMBHASH hash ref to with MEMBERS as keys and 1's as values
+# Once Key "Info" requested:
+# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+# MaxValNameLen MaxValDataLen SecurityLen LastWrite
+# If is tied to a hash and iterating over key values:
+# PREVIDX int; index of last MEMBERS element return
+# If is the key object returned by Load():
+# UNLOADME list ref; information about Load()ed key
+# If is a subkey of a "loaded" key other than the one returned by Load():
+# DEPENDON obj ref; object that can't be destroyed before us
+
+
+#Package-local variables:
+
+# Option flag bits:
+use vars qw(
+ $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin
+ $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls
+);
+BEGIN {
+ $Flag_ArrVal = 0x0001;
+ $Flag_TieVal = 0x0002;
+ $Flag_FastDel = 0x0004;
+ $Flag_HexDWord = 0x0008;
+ $Flag_Split = 0x0010;
+ $Flag_DualTyp = 0x0020;
+ $Flag_DualBin = 0x0040;
+ $Flag_FixNulls = 0x0080;
+}
+
+use vars qw( $RegObj %_Roots %RegHash $Registry );
+
+# Short-hand for HKEY_* constants:
+%_Roots= (
+ "Classes" => HKEY_CLASSES_ROOT,
+ "CUser" => HKEY_CURRENT_USER,
+ "LMachine" => HKEY_LOCAL_MACHINE,
+ "Users" => HKEY_USERS,
+ "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful
+ "CConfig" => HKEY_CURRENT_CONFIG,
+ "DynData" => HKEY_DYN_DATA, # Too picky to be useful
+);
+
+# Basic master Registry object:
+$RegObj= {};
+@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= (
+ "NONE", "", [], "\\", "\\",
+ KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" );
+$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar;
+bless $RegObj;
+
+# Fill cache for master Registry object:
+@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= (
+ [], [ keys(%_Roots) ], [], [] );
+grep( s#$#$RegObj->{DELIM}#,
+ @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } );
+@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen
+ MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}=
+ ( "", 0, 0, 0, 0, 0, 0, 0, 0 );
+
+# Create master Registry tied hash:
+$RegObj->Tie( \%RegHash );
+
+# Create master Registry combination object and tied hash reference:
+$Registry= \%RegHash;
+bless $Registry;
+
+
+# Preloaded methods go here.
+
+
+# Map option names to name of subroutine that controls that option:
+use vars qw( @_opt_subs %_opt_subs );
+@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex
+ FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave );
+@_opt_subs{@_opt_subs}= @_opt_subs;
+
+sub import
+{
+ my $pkg = shift(@_);
+ my $level = $Exporter::ExportLevel;
+ my $expto = caller($level);
+ my @export = ();
+ my @consts = ();
+ my $registry = $Registry->Clone;
+ local( $_ );
+ while( @_ ) {
+ $_= shift(@_);
+ if( /^\$(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" ) if /^\$RegObj$/;
+ push( @export, $_ );
+ } elsif( /^\%(\w+::)*\w+$/ ) {
+ push( @export, $_ );
+ } elsif( /^[$%]/ ) {
+ croak "${PACK}->import: Invalid variable name ($_)";
+ } elsif( /^:/ || /^(H?KEY|REG)_/ ) {
+ push( @consts, $_ );
+ } elsif( ! @_ ) {
+ croak "${PACK}->import: Missing argument after option ($_)";
+ } elsif( exists $_opt_subs{$_} ) {
+ $_= $_opt_subs{$_};
+ $registry->$_( shift(@_) );
+ } elsif( /^TiedRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^TiedHash$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) {
+ $_= '%'.$_ unless '%' eq $1;
+ } elsif( "HASH" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedHash ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ObjectRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" );
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" eq ref($_) ) {
+ push( @export, "ObjRef" );
+ } else {
+ croak "${PACK}->import: Invalid var after ObjectRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ExportLevel$/ ) {
+ $level= shift(@_);
+ $expto= caller($level);
+ } elsif( /^ExportTo$/ ) {
+ undef $level;
+ $expto= caller($level);
+ } else {
+ croak "${PACK}->import: Invalid option ($_)";
+ }
+ }
+ Win32API::Registry->export( $expto, @consts ) if @consts;
+ @export= ('$Registry') unless @export;
+ while( @export ) {
+ $_= shift( @export );
+ if( /^\$((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry;
+ } elsif( /^\%((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \%{"${pack}::$sym"};
+ $registry->Tie( \%{"${pack}::$sym"} );
+ } elsif( "SCALAR" eq ref($_) ) {
+ $$_= $registry;
+ } elsif( "HASH" eq ref($_) ) {
+ $registry->Tie( $_ );
+ } elsif( /^ObjVar$/ ) {
+ $_= shift( @_ );
+ /^\$((?:\w+::)*)(\w+)$/;
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry->ObjectRef;
+ } elsif( /^ObjRef$/ ) {
+ ${shift(@_)}= $registry->ObjectRef;
+ } else {
+ die "Impossible var to export ($_)";
+ }
+ }
+}
+
+
+use vars qw( @_new_Opts %_new_Opts );
+@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON );
+@_new_Opts{@_new_Opts}= (1) x @_new_Opts;
+
+sub _new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $class= ref($this) || $this;
+ my $self= {};
+ my( $handle, $rpath, $opts )= @_;
+ if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n",
+ " options: @_new_Opts\nCalled";
+ }
+ @$self{qw( HANDLE PATH )}= ( $handle, $rpath );
+ @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}=
+ ( $this->Machine, $this->Access, $this->Delimiter,
+ $this->OS_Delimiter, $this->_Roots, $this->_Flags );
+ if( ref($opts) ) {
+ my @err= grep( ! $_new_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->_new: Invalid options (@err)";
+ @$self{ keys(%$opts) }= values(%$opts);
+ }
+ bless $self, $class;
+ return $self;
+}
+
+
+sub _split
+{
+ my $self= shift( @_ );
+ $self= tied(%$self) if tied(%$self);
+ my $path= shift( @_ );
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my $list= [ split( /\Q$delim/, $path ) ];
+ return $list;
+}
+
+
+sub _rootKey
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $keyPath= shift(@_);
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my( $root, $subPath );
+ if( "ARRAY" eq ref($keyPath) ) {
+ $subPath= $keyPath;
+ } else {
+ $subPath= $self->_split( $keyPath, $delim );
+ }
+ $root= shift( @$subPath );
+ if( $root =~ /^HKEY_/ ) {
+ my $handle= Win32API::Registry::constant($root,0);
+ $handle or croak "Invalid HKEY_ constant ($root): $!";
+ return( $self->_new( $handle, [$root], {DELIM=>$delim} ),
+ $subPath );
+ } elsif( $root =~ /^([-+]|0x)?\d/ ) {
+ return( $self->_new( $root, [sprintf("0x%lX",$root)],
+ {DELIM=>$delim} ),
+ $subPath );
+ } else {
+ my $roots= $self->Roots;
+ if( $roots->{$root} ) {
+ return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ),
+ $subPath );
+ }
+ croak "No such root key ($root)";
+ }
+}
+
+
+sub _open
+{
+ my $this = shift(@_);
+ $this = tied(%$this) if ref($this) && tied(%$this);
+ my $subPath = shift(@_);
+ my $sam = @_ ? shift(@_) : $this->Access;
+ my $subKey = join( $this->OS_Delimiter, @$subPath );
+ my $handle = 0;
+ $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) or return ();
+ return $this->_new( $handle, [ @{$this->_Path}, @$subPath ],
+ { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this)
+ : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () )
+ } );
+}
+
+
+sub ObjectRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self;
+}
+
+
+sub _constant
+{
+ my( $name, $desc )= @_;
+ my $value= Win32API::Registry::constant( $name, 0 );
+ my $func= (caller(1))[3];
+ if( 0 == $value ) {
+ if( $! =~ /invalid/i ) {
+ croak "$func: Invalid $desc ($name)";
+ } elsif( 0 != $! ) {
+ croak "$func: \u$desc ($name) not support on this platform";
+ }
+ }
+ return $value;
+}
+
+
+sub _connect
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subPath= pop(@_);
+ $subPath= $this->_split( $subPath ) unless ref($subPath);
+ my $machine= @_ ? shift(@_) : shift(@$subPath);
+ my $handle= 0;
+ my( $temp )= $this->_rootKey( [@$subPath] );
+ $temp->RegConnectRegistry( $machine, $temp->Handle, $handle )
+ or return ();
+ my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} );
+ return( $self, $subPath );
+}
+
+
+use vars qw( @Connect_Opts %Connect_Opts );
+@Connect_Opts= qw(Access Delimiter);
+@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts;
+
+sub Connect
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $machine, $key, $opts )= @_;
+ my $delim= "";
+ my $sam;
+ my $subPath;
+ if( @_ < 2 || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->Connect(",
+ " \$Machine, \$subKey, { OPT=>VAL,... } );\n",
+ " options: @Connect_Opts\nCalled";
+ }
+ if( ref($opts) ) {
+ my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->Connect: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ ( $this, $subPath )= $this->_connect( $machine, $key );
+ return () unless defined($this);
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES
+ Class SecurityLen LastWrite CntValues CntSubKeys
+ MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen );
+
+sub _newVirtual
+{
+ my $self= shift(@_);
+ my( $rPath, $root, $opts )= @_;
+ my $new= $self->_new( "NONE", $rPath, $opts )
+ or return ();
+ @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys};
+ return $new;
+}
+
+
+#$key= new Win32::TieRegistry "LMachine/System/Disk";
+#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk";
+#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} );
+#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} );
+#$key->new( ... );
+
+use vars qw( @new_Opts %new_Opts );
+@new_Opts= qw(Access Delimiter);
+@new_Opts{@new_Opts}= (1) x @new_Opts;
+
+sub new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ if( ! ref($this) ) {
+ no strict "refs";
+ my $self= ${"${this}::Registry"};
+ croak "${this}->new failed since ${PACK}::new sees that ",
+ "\$${this}::Registry is not an object."
+ if ! ref($self);
+ $this= $self->Clone;
+ }
+ my( $subKey, $opts )= @_;
+ my $delim= "";
+ my $dlen;
+ my $sam;
+ my $subPath;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n",
+ " options: @new_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ my @err= grep( ! $new_Opts{$_}, keys(%$opts) );
+ @err and die "${PACK}->new: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $dlen= length($delim);
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ if( "ARRAY" eq ref($subKey) ) {
+ $subPath= $subKey;
+ if( "NONE" eq $this->Handle && @$subPath ) {
+ ( $this, $subPath )= $this->_rootKey( $subPath );
+ }
+ } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) {
+ my $path= $this->_split( substr($subKey,2*$dlen), $delim );
+ my $mach= shift(@$path);
+ if( ! @$path ) {
+ return $this->_newVirtual( $path, $Registry,
+ {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} );
+ }
+ ( $this, $subPath )= $this->_connect( $mach, $path );
+ return () if ! defined($this);
+ if( 0 == @$subPath ) {
+ $this->Delimiter( $delim );
+ return $this;
+ }
+ } elsif( $delim eq substr($subKey,0,$dlen) ) {
+ ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim );
+ } elsif( "NONE" eq $this->Handle && "" ne $subKey ) {
+ my( $mach )= $this->Machine;
+ if( $mach ) {
+ ( $this, $subPath )= $this->_connect( $mach, $subKey );
+ } else {
+ ( $this, $subPath )= $this->_rootKey( $subKey, $delim );
+ }
+ } else {
+ $subPath= $this->_split( $subKey, $delim );
+ }
+ return () unless defined($this);
+ if( 0 == @$subPath && "NONE" eq $this->Handle ) {
+ return $this->_newVirtual( $this->_Path, $this,
+ { DELIM=>$delim, ACCESS=>$sam } );
+ }
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ return $self;
+}
+
+
+sub Open
+{
+ my $self= shift(@_);
+ my $tied= ref($self) && tied(%$self);
+ $self= tied(%$self) if $tied;
+ $self= $self->new( @_ );
+ $self= $self->TiedRef if defined($self) && $tied;
+ return $self;
+}
+
+
+sub Clone
+{
+ my $self= shift( @_ );
+ my $new= $self->Open("");
+ return $new;
+}
+
+
+{ my @flush;
+ sub Flush
+ {
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $flush )= @_;
+ @_ and croak "Usage: \$key->Flush( \$bFlush );";
+ return 0 if "NONE" eq $self->Handle;
+ @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class
+ CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+ MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX )
+ unless @flush;
+ delete( @$self{@flush} );
+ if( defined($flush) && $flush ) {
+ return $self->RegFlushKey();
+ } else {
+ return 1;
+ }
+ }
+}
+
+
+sub _DualVal
+{
+ my( $hRef, $num )= @_;
+ if( $_SetDualVar && $$hRef{$num} ) {
+ &SetDualVar( $num, "$$hRef{$num}", 0+$num );
+ }
+ return $num;
+}
+
+
+use vars qw( @_RegDataTypes %_RegDataTypes );
+@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ
+ REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST REG_NONE );
+# Make sure that REG_DWORD appears _after_ other REG_DWORD_*
+# items above and that REG_NONE appears _last_.
+foreach( @_RegDataTypes ) {
+ $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_;
+}
+
+sub GetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');";
+ my( $valName )= @_;
+ my( $valType, $valData, $dLen )= (0,"",0);
+ return () if "NONE" eq $self->Handle;
+ $self->RegQueryValueEx( $valName, [], $valType, $valData,
+ $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 )
+ ) or return ();
+ if( REG_DWORD == $valType ) {
+ my $val= unpack("L",$valData);
+ $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex;
+ &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals
+ } elsif( REG_BINARY == $valType && length($valData) <= 4 ) {
+ &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) )
+ if $self->DualBinVals;
+ } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType )
+ && $self->FixSzNulls ) {
+ substr($valData,-1)= "" if "\0" eq substr($valData,-1);
+ } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) {
+ ## $valData =~ s/\0\0$//; # Why does this often fail??
+ substr($valData,-2)= "" if "\0\0" eq substr($valData,-2);
+ $valData= [ split( /\0/, $valData, -1 ) ]
+ }
+ if( ! wantarray ) {
+ return $valData;
+ } elsif( ! $self->DualTypes ) {
+ return( $valData, $valType );
+ } else {
+ return( $valData, _DualVal( \%_RegDataTypes, $valType ) );
+ }
+}
+
+
+sub _ErrNum
+{
+ # return $^E;
+ return Win32::GetLastError();
+}
+
+
+sub _ErrMsg
+{
+ # return $^E;
+ return Win32::FormatMessage( Win32::GetLastError() );
+}
+
+sub _Err
+{
+ my $err;
+ # return $^E;
+ return _ErrMsg if ! $_SetDualVar;
+ return &SetDualVar( $err, _ErrMsg, _ErrNum );
+}
+
+sub _NoMoreItems
+{
+ return
+ $_NoMoreItems =~ /^\d/
+ ? _ErrNum == $_NoMoreItems
+ : _ErrMsg =~ /$_NoMoreItems/io;
+}
+
+
+sub _FileNotFound
+{
+ return
+ $_FileNotFound =~ /^\d/
+ ? _ErrNum == $_FileNotFound
+ : _ErrMsg =~ /$_FileNotFound/io;
+}
+
+
+sub _TooSmall
+{
+ return
+ $_TooSmall =~ /^\d/
+ ? _ErrNum == $_TooSmall
+ : _ErrMsg =~ /$_TooSmall/io;
+}
+
+
+sub _MoreData
+{
+ return
+ $_MoreData =~ /^\d/
+ ? _ErrNum == $_MoreData
+ : _ErrMsg =~ /$_MoreData/io;
+}
+
+
+sub _enumValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @names )= ();
+ my $pos= 0;
+ my $name= "";
+ my $nlen= 1+$self->Information("MaxValNameLen");
+ while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) {
+ push( @names, $name );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{VALUES}= \@names;
+ return 1;
+}
+
+
+sub ValueNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->ValueNames;";
+ $self->_enumValues unless $self->{VALUES};
+ return @{$self->{VALUES}};
+}
+
+
+sub _enumSubKeys
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @subkeys, @classes, @times )= ();
+ my $pos= 0;
+ my( $subkey, $class, $time )= ("","","");
+ my( $namSiz, $clsSiz )= $self->Information(
+ qw( MaxSubKeyLen MaxSubClassLen ));
+ $namSiz++; $clsSiz++;
+ while( $self->RegEnumKeyEx(
+ $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) {
+ push( @subkeys, $subkey );
+ push( @classes, $class );
+ push( @times, $time );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{SUBKEYS}= \@subkeys;
+ $self->{SUBCLASSES}= \@classes;
+ $self->{SUBTIMES}= \@times;
+ return 1;
+}
+
+
+sub SubKeyNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->SubKeyNames;";
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ return @{$self->{SUBKEYS}};
+}
+
+
+sub SubKeyClasses
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \@classes= \$key->SubKeyClasses;";
+ $self->_enumSubKeys unless $self->{SUBCLASSES};
+ return @{$self->{SUBCLASSES}};
+}
+
+
+sub SubKeyTimes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@times= \$key->SubKeyTimes;";
+ $self->_enumSubKeys unless $self->{SUBTIMES};
+ return @{$self->{SUBTIMES}};
+}
+
+
+sub _MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;";
+ if( ! $self->{MEMBERS} ) {
+ $self->_enumValues unless $self->{VALUES};
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ),
+ map( $self->{DELIM}.$_, @{$self->{VALUES}} ) );
+ $self->{MEMBERS}= \@members;
+ }
+ return $self->{MEMBERS};
+}
+
+
+sub _MembersHash
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->_MembersHash;";
+ if( ! $self->{MEMBHASH} ) {
+ my $aRef= $self->_MemberNames;
+ $self->{MEMBHASH}= {};
+ @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef;
+ }
+ return $self->{MEMBHASH};
+}
+
+
+sub MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@members= \$key->MemberNames;";
+ return @{$self->_MemberNames};
+}
+
+
+sub Information
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )=
+ ("",0,0,0,0,0,0,0);
+ my $clen= 8;
+ if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls,
+ $nvals, $xname, $xdata, $xsec, $time ) ) {
+ return ();
+ }
+ if( defined($self->{Class}) ) {
+ $clen= length($self->{Class});
+ } else {
+ $self->{Class}= "";
+ }
+ while( ! $self->RegQueryInfoKey( $self->{Class}, $clen,
+ [],[],[],[],[],[],[],[],[])
+ && _MoreData ) {
+ $clen *= 2;
+ }
+ my( %info );
+ @info{ qw( LastWrite CntSubKeys CntValues SecurityLen
+ MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen )
+ }= ( $time, $nkeys, $nvals, $xsec,
+ $xdata, $xkey, $xcls, $xname );
+ if( @_ ) {
+ my( %check );
+ @check{keys(%info)}= keys(%info);
+ my( @err )= grep( ! $check{$_}, @_ );
+ if( @err ) {
+ croak "${PACK}::Information- Invalid info requested (@err)";
+ }
+ return @info{@_};
+ } else {
+ return %info;
+ }
+}
+
+
+sub Delimiter
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ $self= $RegObj unless ref($self);
+ my( $oldDelim )= $self->{DELIM};
+ if( 1 == @_ && "" ne "$_[0]" ) {
+ delete $self->{MEMBERS};
+ delete $self->{MEMBHASH};
+ $self->{DELIM}= "$_[0]";
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);";
+ }
+ return $oldDelim;
+}
+
+
+sub Handle
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$handle= \$key->Handle;";
+ $self= $RegObj unless ref($self);
+ return $self->{HANDLE};
+}
+
+
+sub Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$path= \$key->Path;";
+ my $delim= $self->{DELIM};
+ $self= $RegObj unless ref($self);
+ if( "" eq $self->{MACHINE} ) {
+ return( $delim . join( $delim, @{$self->{PATH}} ) . $delim );
+ } else {
+ return( $delim x 2
+ . join( $delim, $self->{MACHINE}, @{$self->{PATH}} )
+ . $delim );
+ }
+}
+
+
+sub _Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrRef= \$key->_Path;";
+ $self= $RegObj unless ref($self);
+ return $self->{PATH};
+}
+
+
+sub Machine
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$machine= \$key->Machine;";
+ $self= $RegObj unless ref($self);
+ return $self->{MACHINE};
+}
+
+
+sub Access
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$access= \$key->Access;";
+ $self= $RegObj unless ref($self);
+ return $self->{ACCESS};
+}
+
+
+sub OS_Delimiter
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;";
+ return $self->{OS_DELIM};
+}
+
+
+sub _Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$varName= \$key->_Roots;";
+ $self= $RegObj unless ref($self);
+ return $self->{ROOTS};
+}
+
+
+sub Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->Roots;";
+ $self= $RegObj unless ref($self);
+ return eval "\\%$self->{ROOTS}";
+}
+
+
+sub TIEHASH
+{
+ my( $this )= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my( $key )= @_;
+ if( 1 == @_ && ref($key) && "$key" =~ /=/ ) {
+ return $key; # $key is already an object (blessed reference).
+ }
+ return $this->new( @_ );
+}
+
+
+sub Tie
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $hRef )= @_;
+ if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) {
+ croak "Usage: \$key->Tie(\\\%hash);";
+ }
+ return tie %$hRef, ref($self), $self;
+}
+
+
+sub TiedRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $hRef= @_ ? shift(@_) : {};
+ return () if ! defined($self);
+ $self->Tie($hRef);
+ bless $hRef, ref($self);
+ return $hRef;
+}
+
+
+sub _Flags
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlags= $self->{FLAGS};
+ if( 1 == @_ ) {
+ $self->{FLAGS}= shift(@_);
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBits= \$key->_Flags(\$newBits);";
+ }
+ return $oldFlags;
+}
+
+
+sub ArrayValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_ArrVal;
+ } else {
+ $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal );
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub TieValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->TieValues cannot be enabled with this version";
+ $self->{FLAGS} |= $Flag_TieVal;
+ } else {
+ $self->{FLAGS} &= ~$Flag_TieVal;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->TieValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FastDelete
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FastDel;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FastDel;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub SplitMultis
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_Split;
+ } else {
+ $self->{FLAGS} &= ~$Flag_Split;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DWordsToHex
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_HexDWord;
+ } else {
+ $self->{FLAGS} &= ~$Flag_HexDWord;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FixSzNulls
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FixNulls;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FixNulls;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualTypes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualTypes cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualTyp;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualTyp;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualBinVals
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualBinVals cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualBin;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualBin;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub GetOptions
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $opt, $meth );
+ if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) {
+ my $href= @_ ? $_[0] : {};
+ foreach $opt ( grep !/^Allow/, @_opt_subs ) {
+ $meth= $_opt_subs{$opt};
+ $href->{$opt}= $self->$meth();
+ }
+ return @_ ? $self : $href;
+ }
+ my @old;
+ foreach $opt ( @_ ) {
+ $meth= $_opt_subs{$opt};
+ if( defined $meth ) {
+ if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) {
+ croak "${PACK}->GetOptions: Getting current setting of $opt ",
+ "not supported in this release";
+ }
+ push( @old, $self->$meth() );
+ } else {
+ croak "${PACK}->GetOptions: Invalid option ($opt) ",
+ "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub SetOptions
+{
+ my $self= shift(@_);
+ # Don't get object if hash ref so "ref" returns original ref.
+ my( $opt, $meth, @old );
+ while( @_ ) {
+ $opt= shift(@_);
+ $meth= $_opt_subs{$opt};
+ if( ! @_ ) {
+ croak "${PACK}->SetOptions: Option value missing ",
+ "after option name ($opt)";
+ } elsif( defined $meth ) {
+ push( @old, $self->$meth( shift(@_) ) );
+ } elsif( $opt eq substr("reference",0,length($opt)) ) {
+ shift(@_) if @_;
+ push( @old, $self );
+ } else {
+ croak "${PACK}->SetOptions: Invalid option ($opt) ",
+ "not one of ( @_opt_subs )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub _parseTiedEnt
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $ent= shift(@_);
+ my $delim= shift(@_);
+ my $dlen= length( $delim );
+ my $parent= @_ ? shift(@_) : 0;
+ my $off;
+ if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) {
+ if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) {
+ return( substr( $ent, 0, $off ),
+ undef, substr( $ent, $dlen+$off ) );
+ } elsif( $parent ) {
+ return();
+ } else {
+ return( $ent );
+ }
+ } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) {
+ return( undef, substr($ent,$dlen) );
+ } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ if( $parent
+ && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) {
+ return( substr($ent,0,$off),
+ undef, undef, substr($ent,$dlen+$off,-$dlen) );
+ } else {
+ return( substr($ent,0,-$dlen) );
+ }
+ } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) {
+ return(
+ substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) );
+ } else {
+ return( undef, undef, $ent );
+ }
+}
+
+
+sub _FetchValue
+{
+ my $self= shift( @_ );
+ my( $val, $createKey )= @_;
+ my( $data, $type );
+ if( ( $data, $type )= $self->GetValue( $val ) ) {
+ return $self->ArrayValues ? [ $data, $type ]
+ : wantarray ? ( $data, $type )
+ : $data;
+ } elsif( $createKey and $data= $self->new($val) ) {
+ return $data->TiedRef;
+ } else {
+ return ();
+ }
+}
+
+
+sub FETCH
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 );
+ my $sub;
+ if( defined($key) ) {
+ if( defined($self->{MEMBHASH})
+ && $self->{MEMBHASH}->{$key.$delim}
+ && 0 <= index($key,$delim) ) {
+ return ()
+ unless $sub= $self->new( $key,
+ {"Delimiter"=>$self->OS_Delimiter} );
+ $sub->Delimiter($delim);
+ } else {
+ return ()
+ unless $sub= $self->new( $key );
+ }
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ return $sub->_FetchValue( $val );
+ } elsif( ! defined($ambig) ) {
+ return $sub->TiedRef;
+ } elsif( defined($key) ) {
+ return $sub->FETCH( $ambig );
+ } else {
+ return $sub->_FetchValue( $ambig, "" ne $ambig );
+ }
+}
+
+
+sub _FetchOld
+{
+ my( $self, $key )= @_;
+ my $old= $self->FETCH($key);
+ if( $old ) {
+ my $copy= {};
+ %$copy= %$old;
+ return $copy;
+ }
+ # return $^E;
+ return _Err;
+}
+
+
+sub DELETE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ my $fast= defined(wantarray) ? $self->FastDelete : 2;
+ my $old= 1; # Value returned if FastDelete is set.
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ $old= $sub->GetValue($val) || _Err unless 2 <= $fast;
+ $sub->RegDeleteValue( $val );
+ } elsif( defined($subkey) ) {
+ $old= $sub->_FetchOld( $subkey.$delim ) unless $fast;
+ $sub->RegDeleteKey( $subkey );
+ } elsif( defined($ambig) ) {
+ if( defined($key) ) {
+ $old= $sub->DELETE($ambig);
+ } else {
+ $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast;
+ if( defined( $old ) ) {
+ $sub->RegDeleteValue( $ambig );
+ } else {
+ $old= $sub->_FetchOld( $ambig.$delim ) unless $fast;
+ $sub->RegDeleteKey( $ambig );
+ }
+ }
+ } elsif( defined($key) ) {
+ $old= $sub->_FetchOld( $key.$delim ) unless $fast;
+ $sub->RegDeleteKey( $key );
+ } else {
+ croak "${PACK}->DELETE: Key ($ent) can never be deleted";
+ }
+ return $old;
+}
+
+
+sub SetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $name= shift(@_);
+ my $data= shift(@_);
+ my( $type )= @_;
+ my $size;
+ if( ! defined($type) ) {
+ if( "ARRAY" eq ref($data) ) {
+ croak "${PACK}->SetValue: Value is array reference but ",
+ "no data type given"
+ unless 2 == @$data;
+ ( $data, $type )= @$data;
+ } else {
+ $type= REG_SZ;
+ }
+ }
+ $type= _constant($type,"registry value data type") if $type =~ /^REG_/;
+ if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) {
+ $data= join( "\0", @$data ) . "\0\0";
+ ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) );
+ } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type )
+ && $self->FixSzNulls ) {
+ $data .= "\0" unless "\0" eq substr($data,0,-1);
+ } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) {
+ $data= pack( "L", hex($data) );
+ # We could to $data=pack("L",$data) for REG_DWORD but I see
+ # no nice way to always destinguish when to do this or not.
+ }
+ return $self->RegSetValueEx( $name, 0, $type, $data, length($data) );
+}
+
+
+sub StoreKey
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subKey= shift(@_);
+ my $data= shift(@_);
+ my $ent;
+ my $self;
+ if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) {
+ croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n",
+ " subkey data must be a HASH reference";
+ }
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+ } else {
+ $self= $this->CreateKey( $subKey );
+ }
+ return () if ! defined($self);
+ foreach $ent ( keys(%$data) ) {
+ return ()
+ unless $self->STORE( $ent, $$data{$ent} );
+ }
+ return $self;
+}
+
+
+# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key
+# = "string" creates a new REG_SZ value
+# = [ data, type ] creates a new value
+sub STORE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $data= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n",
+ " value data cannot be a HASH reference"
+ if ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->SetValue( $val, $data );
+ } elsif( defined($subkey) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $subkey, $data );
+ } elsif( defined($ambig) ) {
+ if( ref($data) && "$data" =~ /(^|=)HASH/ ) {
+ $sub->StoreKey( $ambig, $data );
+ } else {
+ $sub->SetValue( $ambig, $data );
+ }
+ } elsif( defined($key) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $key, $data );
+ } else {
+ croak "${PACK}->STORE: Key ($ent) can never be created nor set";
+ }
+}
+
+
+sub EXISTS
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ return defined( $self->FETCH($ent) );
+}
+
+
+sub FIRSTKEY
+{
+ my $self= shift(@_);
+ my $members= $self->_MemberNames;
+ $self->{PREVIDX}= 0;
+ return @{$members} ? $members->[0] : undef;
+}
+
+
+sub NEXTKEY
+{
+ my $self= shift(@_);
+ my $prev= shift(@_);
+ my $idx= $self->{PREVIDX};
+ my $members= $self->_MemberNames;
+ if( ! defined($idx) || $prev ne $members->[$idx] ) {
+ $idx= 0;
+ while( $idx < @$members && $prev ne $members->[$idx] ) {
+ $idx++;
+ }
+ }
+ $self->{PREVIDX}= ++$idx;
+ return $members->[$idx];
+}
+
+
+sub DESTROY
+{
+ my $self= shift(@_);
+ return if tied(%$self);
+ my $unload;
+ eval { $unload= $self->{UNLOADME}; 1 }
+ or return;
+ my $debug= $ENV{DEBUG_TIE_REGISTRY};
+ if( defined($debug) ) {
+ if( 1 < $debug ) {
+ my $hand= $self->Handle;
+ my $dep= $self->{DEPENDON};
+ carp "${PACK} destroying ", $self->Path, " (",
+ "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")",
+ defined($dep) ? (" [depends on ",$dep->Path,"]") : ();
+ } else {
+ warn "${PACK} destroying ", $self->Path, ".\n";
+ }
+ }
+ $self->RegCloseKey
+ unless "NONE" eq $self->Handle;
+ if( defined($unload) ) {
+ if( defined($debug) && 1 < $debug ) {
+ my( $obj, $subKey, $file )= @$unload;
+ warn "Unloading ", $self->Path,
+ " (from ", $obj->Path, ", $subKey)...\n";
+ }
+ $self->UnLoad
+ || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n";
+ ## carp "Never unloaded ${PACK}::Load($$unload[2])";
+ }
+ #delete $self->{DEPENDON};
+}
+
+
+use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames );
+@CreateKey_Opts= qw( Access Class Options Delimiter
+ Disposition Security Volatile Backup );
+@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts;
+%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY",
+ REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" );
+
+sub CreateKey
+{
+ my $self= shift(@_);
+ my $tied= tied(%$self);
+ $self= tied(%$self) if $tied;
+ my( $subKey, $opts )= @_;
+ my( $sam )= $self->Access;
+ my( $delim )= $self->Delimiter;
+ my( $class )= "";
+ my( $flags )= 0;
+ my( $secure )= [];
+ my( $garb )= [];
+ my( $result )= \$garb;
+ my( $handle )= 0;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n",
+ " options: @CreateKey_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ $sam= $opts->{"Access"} if defined($opts->{"Access"});
+ $class= $opts->{Class} if defined($opts->{Class});
+ $flags= $opts->{Options} if defined($opts->{Options});
+ $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"});
+ $secure= $opts->{Security} if defined($opts->{Security});
+ if( defined($opts->{Disposition}) ) {
+ "SCALAR" eq ref($opts->{Disposition})
+ or croak "${PACK}->CreateKey option `Disposition'",
+ " must provide a scalar reference";
+ $result= $opts->{Disposition};
+ }
+ if( 0 == $flags ) {
+ $flags |= REG_OPTION_VOLATILE
+ if defined($opts->{Volatile}) && $opts->{Volatile};
+ $flags |= REG_OPTION_BACKUP_RESTORE
+ if defined($opts->{Backup}) && $opts->{Backup};
+ }
+ }
+ my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim);
+ $subKey= join( $self->OS_Delimiter, @$subPath );
+ $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam,
+ $secure, $handle, $$result )
+ or return ();
+ if( ! ref($$result) && $self->DualTypes ) {
+ $$result= _DualVal( \%_KeyDispNames, $$result );
+ }
+ my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] );
+ $new->{ACCESS}= $sam;
+ $new->{DELIM}= $delim;
+ $new= $new->TiedRef if $tied;
+ return $new;
+}
+
+
+use vars qw( $Load_Cnt @Load_Opts %Load_Opts );
+$Load_Cnt= 0;
+@Load_Opts= qw(NewSubKey);
+@Load_Opts{@Load_Opts}= (1) x @Load_Opts;
+
+sub Load
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $file, $subKey, $opts )= @_;
+ if( 2 == @_ && "HASH" eq ref($subKey) ) {
+ $opts= $subKey;
+ undef $subKey;
+ }
+ @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts)
+ and croak "Usage: \$key= ",
+ "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n",
+ " options: @Load_Opts @new_Opts\nCalled";
+ if( defined($opts) && exists($opts->{NewSubKey}) ) {
+ $subKey= delete $opts->{NewSubKey};
+ }
+ if( ! defined( $subKey ) ) {
+ if( "" ne $this->Machine ) {
+ ( $this )= $this->_connect( [$this->Machine,"LMachine"] );
+ } else {
+ ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users"
+ }
+ $subKey= "PerlTie:$$." . ++$Load_Cnt;
+ }
+ $this->RegLoadKey( $subKey, $file )
+ or return ();
+ my $self= $this->new( $subKey, defined($opts) ? $opts : () );
+ if( ! defined( $self ) ) {
+ { my $err= Win32::GetLastError();
+ #{ local( $^E ); #}
+ $this->RegUnLoadKey( $subKey ) or carp
+ "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n";
+ Win32::SetLastError($err);
+ }
+ return ();
+ }
+ $self->{UNLOADME}= [ $this, $subKey, $file ];
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+sub UnLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$key->UnLoad;";
+ my $unload= $self->{UNLOADME};
+ "ARRAY" eq ref($unload)
+ or croak "${PACK}->UnLoad called on a key which was not Load()ed";
+ my( $obj, $subKey, $file )= @$unload;
+ $self->RegCloseKey;
+ return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey );
+}
+
+
+sub AllowSave
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeBackupPrivilege", @_ );
+}
+
+
+sub AllowLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeRestorePrivilege", @_ );
+}
+
+
+# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync )
+
+
+sub RegCloseKey { my $self= shift(@_);
+ Win32API::Registry::RegCloseKey $self->Handle, @_; }
+sub RegConnectRegistry { my $self= shift(@_);
+ Win32API::Registry::RegConnectRegistry @_; }
+sub RegCreateKey { my $self= shift(@_);
+ Win32API::Registry::RegCreateKey $self->Handle, @_; }
+sub RegCreateKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegCreateKeyEx $self->Handle, @_; }
+sub RegDeleteKey { my $self= shift(@_);
+ Win32API::Registry::RegDeleteKey $self->Handle, @_; }
+sub RegDeleteValue { my $self= shift(@_);
+ Win32API::Registry::RegDeleteValue $self->Handle, @_; }
+sub RegEnumKey { my $self= shift(@_);
+ Win32API::Registry::RegEnumKey $self->Handle, @_; }
+sub RegEnumKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegEnumKeyEx $self->Handle, @_; }
+sub RegEnumValue { my $self= shift(@_);
+ Win32API::Registry::RegEnumValue $self->Handle, @_; }
+sub RegFlushKey { my $self= shift(@_);
+ Win32API::Registry::RegFlushKey $self->Handle, @_; }
+sub RegGetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegGetKeySecurity $self->Handle, @_; }
+sub RegLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegLoadKey $self->Handle, @_; }
+sub RegNotifyChangeKeyValue { my $self= shift(@_);
+ Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; }
+sub RegOpenKey { my $self= shift(@_);
+ Win32API::Registry::RegOpenKey $self->Handle, @_; }
+sub RegOpenKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegOpenKeyEx $self->Handle, @_; }
+sub RegQueryInfoKey { my $self= shift(@_);
+ Win32API::Registry::RegQueryInfoKey $self->Handle, @_; }
+sub RegQueryMultipleValues { my $self= shift(@_);
+ Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; }
+sub RegQueryValue { my $self= shift(@_);
+ Win32API::Registry::RegQueryValue $self->Handle, @_; }
+sub RegQueryValueEx { my $self= shift(@_);
+ Win32API::Registry::RegQueryValueEx $self->Handle, @_; }
+sub RegReplaceKey { my $self= shift(@_);
+ Win32API::Registry::RegReplaceKey $self->Handle, @_; }
+sub RegRestoreKey { my $self= shift(@_);
+ Win32API::Registry::RegRestoreKey $self->Handle, @_; }
+sub RegSaveKey { my $self= shift(@_);
+ Win32API::Registry::RegSaveKey $self->Handle, @_; }
+sub RegSetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegSetKeySecurity $self->Handle, @_; }
+sub RegSetValue { my $self= shift(@_);
+ Win32API::Registry::RegSetValue $self->Handle, @_; }
+sub RegSetValueEx { my $self= shift(@_);
+ Win32API::Registry::RegSetValueEx $self->Handle, @_; }
+sub RegUnLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegUnLoadKey $self->Handle, @_; }
+sub AllowPriv { my $self= shift(@_);
+ Win32API::Registry::AllowPriv @_; }
+
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Win32::TieRegistry - Manipulate the Win32 Registry
+
+=head1 SYNOPSIS
+
+ use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] );
+
+ $Registry->SomeMethodCall(arg1,...);
+
+ $subKey= $Registry->{"Key\\SubKey\\"};
+ $valueData= $Registry->{"Key\\SubKey\\\\ValueName"};
+ $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} };
+ $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData";
+ $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ];
+
+=head1 EXAMPLES
+
+ use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 );
+ $pound= $Registry->Delimiter("/");
+ $diskKey= $Registry->{"LMachine/System/Disk/"}
+ or die "Can't read LMachine/System/Disk key: $^E\n";
+ $data= $key->{"/Information"}
+ or die "Can't read LMachine/System/Disk//Information value: $^E\n";
+ $remoteKey= $Registry->{"//ServerA/LMachine/System/"}
+ or die "Can't read //ServerA/LMachine/System/ key: $^E\n";
+ $remoteData= $remoteKey->{"Disk//Information"}
+ or die "Can't read ServerA's System/Disk//Information value: $^E\n";
+ foreach $entry ( keys(%$diskKey) ) {
+ ...
+ }
+ foreach $subKey ( $diskKey->SubKeyNames ) {
+ ...
+ }
+ $diskKey->AllowSave( 1 );
+ $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] );
+
+=head1 DESCRIPTION
+
+The I<Win32::TieRegistry> module lets you manipulate the Registry
+via objects [as in "object oriented"] or via tied hashes. But
+you will probably mostly use a combination reference, that is, a
+reference to a tied hash that has also been made an object so that
+you can mix both access methods [as shown above].
+
+If you did not get this module as part of L<libwin32>, you might
+want to get a recent version of L<libwin32> from CPAN which should
+include this module and the I<Win32API::Registry> module that it
+uses.
+
+Skip to the L<SUMMARY> section if you just want to dive in and start
+using the Registry from Perl.
+
+Accessing and manipulating the registry is extremely simple using
+I<Win32::TieRegistry>. A single, simple expression can return
+you almost any bit of information stored in the Registry.
+I<Win32::TieRegistry> also gives you full access to the "raw"
+underlying API calls so that you can do anything with the Registry
+in Perl that you could do in C. But the "simple" interface has
+been carefully designed to handle almost all operations itself
+without imposing arbitrary limits while providing sensible
+defaults so you can list only the parameters you care about.
+
+But first, an overview of the Registry itself.
+
+=head2 The Registry
+
+The Registry is a forest: a collection of several tree structures.
+The root of each tree is a key. These root keys are identified by
+predefined constants whose names start with "HKEY_". Although all
+keys have a few attributes associated with each [a class, a time
+stamp, and security information], the most important aspect of keys
+is that each can contain subkeys and can contain values.
+
+Each subkey has a name: a string which cannot be blank and cannot
+contain the delimiter character [backslash: C<'\\'>] nor nul
+[C<'\0'>]. Each subkey is also a key and so can contain subkeys
+and values [and has a class, time stamp, and security information].
+
+Each value has a name: a string which B<can> be blank and B<can>
+contain the delimiter character [backslash: C<'\\'>] and any
+character except for null, C<'\0'>. Each value also has data
+associated with it. Each value's data is a contiguous chunk of
+bytes, which is exactly what a Perl string value is so Perl
+strings will usually be used to represent value data.
+
+Each value also has a data type which says how to interpret the
+value data. The primary data types are:
+
+=over
+
+=item REG_SZ
+
+A null-terminated string.
+
+=item REG_EXPAND_SZ
+
+A null-terminated string which contains substrings consisting of a
+percent sign [C<'%'>], an environment variable name, then a percent
+sign, that should be replaced with the value associate with that
+environment variable. The system does I<not> automatically do this
+substitution.
+
+=item REG_BINARY
+
+Some arbitrary binary value. You can think of these as being
+"packed" into a string.
+
+If your system has the L<SetDualVar> module installed,
+the C<DualBinVals()> option wasn't turned off, and you
+fetch a C<REG_BINARY> value of 4 bytes or fewer, then
+you can use the returned value in a numeric context to
+get at the "unpacked" numeric value. See C<GetValue()>
+for more information.
+
+=item REG_MULTI_SZ
+
+Several null-terminated strings concatenated together with an
+extra trailing C<'\0'> at the end of the list. Note that the list
+can include empty strings so use the value's length to determine
+the end of the list, not the first occurrence of C<'\0\0'>.
+It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry>
+will split these values into an array of strings for you.
+
+=item REG_DWORD
+
+A long [4-byte] integer value. These values are expected either
+packed into a 4-character string or as a hex string of B<more than>
+4 characters [but I<not> as a numeric value, unfortunately, as there is
+no sure way to tell a numeric value from a packed 4-byte string that
+just happens to be a string containing a valid numeric value].
+
+How such values are returned depends on the C<DualBinVals()> and
+C<DWordsToHex()> options. See C<GetValue()> for details.
+
+=back
+
+In the underlying Registry calls, most places which take a
+subkey name also allow you to pass in a subkey "path" -- a
+string of several subkey names separated by the delimiter
+character, backslash [C<'\\'>]. For example, doing
+C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much
+like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>,
+then opening its C<"DISK"> subkey, then closing the C<"SYSTEM">
+subkey.
+
+All of the I<Win32::TieRegistry> features allow you to use your
+own delimiter in place of the system's delimiter, [C<'\\'>]. In
+most of our examples we will use a forward slash [C<'/'>] as our
+delimiter as it is easier to read and less error prone to use when
+writing Perl code since you have to type two backslashes for each
+backslash you want in a string. Note that this is true even when
+using single quotes -- C<'\\HostName\LMachine\'> is an invalid
+string and must be written as C<'\\\\HostName\\LMachine\\'>.
+
+You can also connect to the registry of other computers on your
+network. This will be discussed more later.
+
+Although the Registry does not have a single root key, the
+I<Win32::TieRegistry> module creates a virtual root key for you
+which has all of the I<HKEY_*> keys as subkeys.
+
+=head2 Tied Hashes Documentation
+
+Before you can use a tied hash, you must create one. One way to
+do that is via:
+
+ use Win32::TieRegistry ( TiedHash => '%RegHash' );
+
+which exports a C<%RegHash> variable into your package and ties it
+to the virtual root key of the Registry. An alternate method is:
+
+ my %RegHash;
+ use Win32::TieRegistry ( TiedHash => \%RegHash );
+
+There are also several ways you can tie a hash variable to any
+other key of the Registry, which are discussed later.
+
+Note that you will most likely use C<$Registry> instead of using
+a tied hash. C<$Registry> is a reference to a hash that has
+been tied to the virtual root of your computer's Registry [as if,
+C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}>
+rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather
+than C<keys %RegHash>, for example.
+
+For each hash which has been tied to a Registry key, the Perl
+C<keys> function will return a list containing the name of each
+of the key's subkeys with a delimiter character appended to it and
+containing the name of each of the key's values with a delimiter
+prepended to it. For example:
+
+ keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } )
+
+might yield the following list value:
+
+ ( "DefaultIcon\\", # The subkey named "DefaultIcon"
+ "shell\\", # The subkey named "shell"
+ "shellex\\", # The subkey named "shellex"
+ "\\", # The default value [named ""]
+ "\\EditFlags" ) # The value named "EditFlags"
+
+For the virtual root key, short-hand subkey names are used as
+shown below. You can use the short-hand name, the regular
+I<HKEY_*> name, or any numeric value to access these keys, but
+the short-hand names are all that will be returned by the C<keys>
+function.
+
+=over
+
+=item "Classes" for HKEY_CLASSES_ROOT
+
+Contains mappings between file name extensions and the uses
+for such files along with configuration information for COM
+[MicroSoft's Common Object Model] objects. Usually a link to
+the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE>
+key.
+
+=item "CUser" for HKEY_CURRENT_USER
+
+Contains information specific to the currently logged-in user.
+Mostly software configuration information. Usually a link to
+a subkey of the C<HKEY_USERS> key.
+
+=item "LMachine" for HKEY_LOCAL_MACHINE
+
+Contains all manner of information about the computer.
+
+=item "Users" for HKEY_USERS
+
+Contains one subkey, C<".DEFAULT">, which gets copied to a new
+subkey whenever a new user is added. Also contains a subkey for
+each user of the system, though only those for active users
+[usually only one] are loaded at any given time.
+
+=item "PerfData" for HKEY_PERFORMANCE_DATA
+
+Used to access data about system performance. Access via this key
+is "special" and all but the most carefully constructed calls will
+fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you
+can't enumerate key names without also enumerating values which
+require huge buffers but the exact buffer size required cannot be
+determined beforehand because C<RegQueryInfoKey()> B<always> fails
+with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no
+matter how it is called. So it is currently not very useful to
+tie a hash to this key. You can use it to create an object to use
+for making carefully constructed calls to the underlying Reg*()
+routines.
+
+=item "CConfig" for HKEY_CURRENT_CONFIG
+
+Contains minimal information about the computer's current
+configuration that is required very early in the boot process.
+For example, setting for the display adapter such as screen
+resolution and refresh rate are found in here.
+
+=item "DynData" for HKEY_DYN_DATA
+
+Dynamic data. We have found no documentation for this key.
+
+=back
+
+A tied hash is much like a regular hash variable in Perl -- you give
+it a key string inside braces, [C<{> and C<}>], and it gives you
+back a value [or lets you set a value]. For I<Win32::TieRegistry>
+hashes, there are two types of values that will be returned.
+
+=over
+
+=item SubKeys
+
+If you give it a string which represents a subkey, then it will
+give you back a reference to a hash which has been tied to that
+subkey. It can't return the hash itself, so it returns a
+reference to it. It also blesses that reference so that it is
+also an object so you can use it to call method functions.
+
+=item Values
+
+If you give it a string which is a value name, then it will give
+you back a string which is the data for that value. Alternately,
+you can request that it give you both the data value string and
+the data value type [we discuss how to request this later]. In
+this case, it would return a reference to an array where the value
+data string is element C<[0]> and the value data type is element
+C<[1]>.
+
+=back
+
+The key string which you use in the tied hash must be interpreted
+to determine whether it is a value name or a key name or a path
+that combines several of these or even other things. There are
+two simple rules that make this interpretation easy and
+unambiguous:
+
+ Put a delimiter after each key name.
+ Put a delimiter in front of each value name.
+
+Exactly how the key string will be intepreted is governed by the
+following cases, in the order listed. These cases are designed
+to "do what you mean". Most of the time you won't have to think
+about them, especially if you follow the two simple rules above.
+After the list of cases we give several examples which should be
+clear enough so feel free to skip to them unless you are worried
+about the details.
+
+=over
+
+=item Remote machines
+
+If the hash is tied to the virtual root of the registry [or the
+virtual root of a remote machine's registry], then we treat hash
+key strings which start with the delimiter character specially.
+
+If the hash key string starts with two delimiters in a row, then
+those should be immediately followed by the name of a remote
+machine whose registry we wish to connect to. That can be
+followed by a delimiter and more subkey names, etc. If the
+machine name is not following by anything, then a virtual root
+for the remote machine's registry is created, a hash is tied to
+it, and a reference to that hash it is returned.
+
+=item Hash key string starts with the delimiter
+
+If the hash is tied to a virtual root key, then the leading
+delimiter is ignored. It should be followed by a valid Registry
+root key name [either a short-hand name like C<"LMachine">, an
+I<HKEY_*> value, or a numeric value]. This alternate notation is
+allowed in order to be more consistant with the C<Open()> method
+function.
+
+For all other Registry keys, the leading delimiter indicates
+that the rest of the string is a value name. The leading
+delimiter is stripped and the rest of the string [which can
+be empty and can contain more delimiters] is used as a value
+name with no further parsing.
+
+=item Exact match with direct subkey name followed by delimiter
+
+If you have already called the Perl C<keys> function on the tied
+hash [or have already called C<MemberNames> on the object] and the
+hash key string exactly matches one of the strings returned, then
+no further parsing is done. In other words, if the key string
+exactly matches the name of a direct subkey with a delimiter
+appended, then a reference to a hash tied to that subkey is
+returned [but only if C<keys> or C<MemberNames> has already
+been called for that tied hash].
+
+This is only important if you have selected a delimiter other than
+the system default delimiter and one of the subkey names contains
+the delimiter you have chosen. This rule allows you to deal with
+subkeys which contain your chosen delimiter in their name as long
+as you only traverse subkeys one level at a time and always
+enumerate the list of members before doing so.
+
+The main advantage of this is that Perl code which recursively
+traverses a hash will work on hashes tied to Registry keys even if
+a non-default delimiter has been selected.
+
+=item Hash key string contains two delimiters in a row
+
+If the hash key string contains two [or more] delimiters in a row,
+then the string is split between the first pair of delimiters.
+The first part is interpreted as a subkey name or a path of subkey
+names separated by delimiters and with a trailing delimiter. The
+second part is interpreted as a value name with one leading
+delimiter [any extra delimiters are considered part of the value
+name].
+
+=item Hash key string ends with a delimiter
+
+If the key string ends with a delimiter, then it is treated
+as a subkey name or path of subkey names separated by delimiters.
+
+=item Hash key string contains a delimiter
+
+If the key string contains a delimiter, then it is split after
+the last delimiter. The first part is treated as a subkey name or
+path of subkey names separated by delimiters. The second part
+is ambiguous and is treated as outlined in the next item.
+
+=item Hash key string contains no delimiters
+
+If the hash key string contains no delimiters, then it is ambiguous.
+
+If you are reading from the hash [fetching], then we first use the
+key string as a value name. If there is a value with a matching
+name in the Registry key which the hash is tied to, then the value
+data string [and possibly the value data type] is returned.
+Otherwise, we retry by using the hash key string as a subkey name.
+If there is a subkey with a matching name, then we return a
+reference to a hash tied to that subkey. Otherwise we return
+C<undef>.
+
+If you are writing to the hash [storing], then we use the key
+string as a subkey name only if the value you are storing is a
+reference to a hash value. Otherwise we use the key string as
+a value name.
+
+=back
+
+=head3 Examples
+
+Here are some examples showing different ways of accessing Registry
+information using references to tied hashes:
+
+=over
+
+=item Canonical value fetch
+
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
+ . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'};
+
+Should return the text of important tip number 18. Note that two
+backslashes, C<"\\">, are required to get a single backslash into
+a Perl double-quoted or single-qouted string. Note that C<"\\">
+is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through
+C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">.
+
+=item Changing your delimiter
+
+ $Registry->Delimiter("/");
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/"
+ . 'Windows/CurrentVersion/Explorer/Tips//18'};
+
+This usually makes things easier to read when working in Perl.
+All remaining examples will assume the delimiter has been changed
+as above.
+
+=item Using intermediate keys
+
+ $ms= $Registry->{"LMachine/Software/Microsoft/"};
+ $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"};
+ $tip18= $winlogon->{"/18"};
+
+Same as above but opens more keys into the Registry which lets you
+efficiently re-access those intermediate keys. This is slightly
+less efficient if you never reuse those intermediate keys.
+
+=item Chaining in a single statement
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"};
+
+Like above, this creates intermediate key objects then uses
+them to access other data. Once this statement finishes, the
+intermediate key objects are destroyed. Several handles into
+the Registry are opened and closed by this statement so it is
+less efficient but there are times when this will be useful.
+
+=item Even less efficient example of chaining
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"};
+
+Because we left off the trailing delimiters, I<Win32::TieRegistry>
+doesn't know whether final names, C<"Microsoft"> and C<"Tips">,
+are subkey names or value names. So this statement ends up
+executing the same code as the next one.
+
+=item What the above really does
+
+ $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"};
+
+With more chains to go through, more temporary objects are created
+and later destroyed than in our first chaining example. Also,
+when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first
+tries to open it as a value and fails then tries it as a subkey.
+The same is true for when it looks up C<"Tips">.
+
+=item Getting all of the tips
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ foreach( keys %$tips ) {
+ print "$_: ", $tips->{$_}, "\n";
+ }
+
+First notice that we actually check for failure for the first
+time. We are assuming that the C<"Tips"> key contains no subkeys.
+Otherwise the C<print> statement would show something like
+C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey.
+
+The output from the above code will start something like:
+
+ /0: If you don't know how to do something,[...]
+
+=back
+
+=head3 Deleting items
+
+You can use the Perl C<delete> function to delete a value from a
+Registry key or to delete a subkey as long that subkey contains
+no subkeys of its own. See L<More Examples>, below, for more
+information.
+
+=head3 Storing items
+
+You can use the Perl assignment operator [C<=>] to create new
+keys, create new values, or replace values. The values you store
+should be in the same format as the values you would fetch from a
+tied hash. For example, you can use a single assignment statement
+to copy an entire Registry tree. The following statement:
+
+ $Registry->{"LMachine/Software/Classes/Tie_Registry/"}=
+ $Registry->{"LMachine/Software/Classes/batfile/"};
+
+creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes">
+subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it
+with copies of all of the subkeys and values in the C<"batfile">
+subkey and all of its subkeys. Note that you need to have
+called C<$Registry-E<gt>ArrayValues(1)> for the proper value data
+type information to be copied. Note also that this release of
+I<Win32::TieRegistry> does not copy key attributes such as class
+name and security information [this is planned for a future release].
+
+The following statement creates a whole subtree in the Registry:
+
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+Note that all but the last Registry key used on the left-hand
+side of the assignment [that is, "LMachine/Software/" but not
+"FooCorp/"] must already exist for this statement to succeed.
+
+By using the leading a trailing delimiters on each subkey name and
+value name, I<Win32::TieRegistry> will tell you if you try to assign
+subkey information to a value or visa-versa.
+
+=head3 More examples
+
+=over
+
+=item Adding a new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tips{'/186'}= "Be very careful when making changes to the Registry!";
+
+=item Deleting our new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tip186= delete $tips{'/186'};
+
+Note that Perl's C<delete> function returns the value that was deleted.
+
+=item Adding a new tip differently
+
+ $Registry->{"LMachine/Software/Microsoft/" .
+ "Windows/CurrentVersion/Explorer/Tips//186"}=
+ "Be very careful when making changes to the Registry!";
+
+=item Deleting differently
+
+ $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips//186"};
+
+Note that this only deletes the tail of what we looked up, the
+C<"186"> value, not any of the keys listed.
+
+=item Deleting a key
+
+WARNING: The following code will delete all information about the
+current user's tip preferences. Actually executing this command
+would probably cause the user to see the Welcome screen the next
+time they log in and may cause more serious problems. This
+statement is shown as an example only and should not be used when
+experimenting.
+
+ $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+
+This deletes the C<"Tips"> key and the values it contains. The
+C<delete> function will return a reference to a hash [not a tied
+hash] containing the value names and value data that were deleted.
+
+The information to be returned is copied from the Registry into a
+regular Perl hash before the key is deleted. If the key has many
+subkeys, this copying could take a significant amount of memory
+and/or processor time. So you can disable this process by calling
+the C<FastDelete> member function:
+
+ $prevSetting= $regKey->FastDelete(1);
+
+which will cause all subsequent delete operations via C<$regKey>
+to simply return a true value if they succeed. This optimization
+is automatically done if you use C<delete> in a void context.
+
+=item Technical notes on deleting
+
+If you use C<delete> to delete a Registry key or value and use
+the return value, then I<Win32::TieRegistry> usually looks up the
+current contents of that key or value so they can be returned if
+the deletion is successful. If the deletion succeeds but the
+attempt to lookup the old contents failed, then the return value
+of C<delete> will be C<$^E> from the failed part of the operation.
+
+=item Undeleting a key
+
+ $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"}= $tips;
+
+This adds back what we just deleted. Note that this version of
+I<Win32::TieRegistry> will use defaults for the key attributes
+[such as class name and security] and will not restore the
+previous attributes.
+
+=item Not deleting a key
+
+WARNING: Actually executing the following code could cause
+serious problems. This statement is shown as an example only and
+should not be used when experimenting.
+
+ $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"}
+ defined($res) || die "Can't delete URL key: $^E\n";
+
+Since the "Windows" key should contain subkeys, that C<delete>
+statement should make no changes to the Registry, return C<undef>,
+and set C<$^E> to "Access is denied".
+
+=item Not deleting again
+
+ $tips= $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+ delete $tips;
+
+The Perl C<delete> function requires that its argument be an
+expression that ends in a hash element lookup [or hash slice],
+which is not the case here. The C<delete> function doesn't
+know which hash $tips came from and so can't delete it.
+
+=back
+
+=head2 Objects Documentation
+
+The following member functions are defined for use on
+I<Win32::TieRegistry> objects:
+
+=over
+
+=item new
+
+The C<new> method creates a new I<Win32::TieRegistry> object.
+C<new> is mostly a synonym for C<Open()> so see C<Open()> below for
+information on what arguments to pass in. Examples:
+
+ $machKey= new Win32::TieRegistry "LMachine"
+ or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n";
+ $userKey= Win32::TieRegistry->new("CUser")
+ or die "Can't access HKEY_CURRENT_USER key: $^E\n";
+
+Note that calling C<new> via a reference to a tied hash returns
+a simple object, not a reference to a tied hash.
+
+=item Open
+
+=item $subKey= $key->Open( $sSubKey, $rhOptions )
+
+The C<Open> method opens a Registry key and returns a new
+I<Win32::TieRegistry> object associated with that Registry key.
+If C<Open> is called via a reference to a tied hash, then C<Open>
+returns another reference to a tied hash. Otherwise C<Open>
+returns a simple object and you should then use C<TiedRef> to get
+a reference to a tied hash.
+
+C<$sSubKey> is a string specifying a subkey to be opened.
+Alternately C<$sSubKey> can be a reference to an array value
+containing the list of increasingly deep subkeys specifying the
+path to the subkey to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Open> method supports two options, C<"Delimiter">
+and C<"Access">, and C<$rhOptions> should have only have zero or
+more of these strings as keys. See the "Examples" section below
+for more information.
+
+The C<"Delimiter"> option specifies what string [usually a single
+character] will be used as the delimiter to be appended to subkey
+names and prepended to value names. If this option is not specified,
+the new key [C<$subKey>] inherits the delimiter of the old key
+[C<$key>].
+
+The C<"Access"> option specifies what level of access to the
+Registry key you wish to have once it has been opened. If this
+option is not specified, the new key [C<$subKey>] is opened with
+the same access level used when the old key [C<$key>] was opened.
+The virtual root of the Registry pretends it was opened with
+access C<KEY_READ()|KEY_WRITE()> so this is the default access when
+opening keys directory via C<$Registry>. If you don't plan on
+modifying a key, you should open it with C<KEY_READ> access as
+you may not have C<KEY_WRITE> access to it or some of its subkeys.
+
+If the C<"Access"> option value is a string that starts with
+C<"KEY_">, then it should match B<one> of the predefined access
+levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or
+C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module.
+Otherwise, a numeric value is expected. For maximum flexibility,
+include C<use Win32::TieRegistry qw(:KEY_);>, for example, near
+the top of your script so you can specify more complicated access
+levels such as C<KEY_READ()|KEY_WRITE()>.
+
+If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey>
+is an array reference], then the path to the subkey to be opened
+will be relative to the path of the original key [C<$key>]. If
+C<$sSubKey> begins with a single delimiter, then the path to the
+subkey to be opened will be relative to the virtual root of the
+Registry on whichever machine the original key resides. If
+C<$sSubKey> begins with two consectutive delimiters, then those
+must be followed by a machine name which causes the C<Connect()>
+method function to be called.
+
+Examples:
+
+ $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} )
+ or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n";
+ $swKey= $machKey->Open( "Software" );
+ $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" );
+ $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] );
+ $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) );
+
+ $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} )
+ or die "Can't connect to HostA or can't open subkey: $^E\n";
+
+=item Clone
+
+=item $copy= $key->Clone
+
+Creates a new object that is associated with the same Registry key
+as the invoking object.
+
+=item Connect
+
+=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions )
+
+The C<Connect> method connects to the Registry of a remote machine,
+and opens a key within it, then returns a new I<Win32::TieRegistry>
+object associated with that remote Registry key. If C<Connect>
+was called using a reference to a tied hash, then the return value
+will also be a reference to a tied hash [or C<undef>]. Otherwise,
+if you wish to use the returned object as a tied hash [not just as
+an object], then use the C<TiedRef> method function after C<Connect>.
+
+C<$sMachineName> is the name of the remote machine. You don't have
+to preceed the machine name with two delimiter characters.
+
+C<$sKeyPath> is a string specifying the remote key to be opened.
+Alternately C<$sKeyPath> can be a reference to an array value
+containing the list of increasingly deep keys specifying the path
+to the key to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Connect> method supports two options, C<"Delimiter">
+and C<"Access">. See the C<Open> method documentation for more
+information on these options.
+
+C<$sKeyPath> is already relative to the virtual root of the Registry
+of the remote machine. A single leading delimiter on C<sKeyPath>
+will be ignored and is not required.
+
+C<$sKeyPath> can be empty in which case C<Connect> will return an
+object representing the virtual root key of the remote Registry.
+Each subsequent use of C<Open> on this virtual root key will call
+the system C<RegConnectRegistry> function.
+
+The C<Connect> method can be called via any I<Win32::TieRegistry>
+object, not just C<$Registry>. Attributes such as the desired
+level of access and the delimiter will be inherited from the
+object used but the C<$sKeyPath> will always be relative to the
+virtual root of the remote machine's registry.
+
+Examples:
+
+ $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} )
+ or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www.microsoft.com",
+ "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/",
+ { Access=>KEY_READ, Delimiter=>"/" } )
+ or die "Can't check what version of IIS Microsoft is running: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www",
+ qw(LMachine Software Microsoft Inetsrv CurrentVersion) )
+ or die "Can't check what version of IIS we are running: $^E\n";
+
+=item ObjectRef
+
+=item $object_ref= $obj_or_hash_ref->ObjectRef
+
+For a simple object, just returns itself [C<$obj == $obj->ObjectRef>].
+
+For a reference to a tied hash [if it is also an object], C<ObjectRef>
+returns the simple object that the hash is tied to.
+
+This is primarilly useful when debugging since typing C<x $Registry>
+will try to display your I<entire> registry contents to your screen.
+But the debugger command C<x $Registry->ObjectRef> will just dump
+the implementation details of the underlying object to your screen.
+
+=item Flush( $bFlush )
+
+Flushes all cached information about the Registry key so that future
+uses will get fresh data from the Registry.
+
+If the optional C<$bFlush> is specified and a true value, then
+C<RegFlushKey()> will be called, which is almost never necessary.
+
+=item GetValue
+
+=item $ValueData= $key->GetValue( $sValueName )
+
+=item ($ValueData,$ValueType)= $key->GetValue( $sValueName )
+
+Gets a Registry value's data and data type.
+
+C<$ValueData> is usually just a Perl string that contains the
+value data [packed into it]. For certain types of data, however,
+C<$ValueData> may be processed as described below.
+
+C<$ValueType> is the C<REG_*> constant describing the type of value
+data stored in C<$ValueData>. If the C<DualTypes()> option is on,
+then C<$ValueType> will be a dual value. That is, when used in a
+numeric context, C<$ValueType> will give the numeric value of a
+C<REG_*> constant. However, when used in a non-numeric context,
+C<$ValueType> will return the name of the C<REG_*> constant, for
+example C<"REG_SZ"> [note the quotes]. So both of the following
+can be true at the same time:
+
+ $ValueType == REG_SZ()
+ $ValueType eq "REG_SZ"
+
+=over
+
+=item REG_SZ and REG_EXPAND_SZ
+
+If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be
+stripped [unless there isn't one] before values of type C<REG_SZ>
+and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add
+a trailing C<'\0'> under similar circumstances.
+
+=item REG_MULTI_SZ
+
+If the C<SplitMultis()> option is on, then values of this type are
+returned as a reference to an array containing the strings. For
+example, a value that, with C<SplitMultis()> off, would be returned as:
+
+ "Value1\000Value2\000\000"
+
+would be returned, with C<SplitMultis()> on, as:
+
+ [ "Value1", "Value2" ]
+
+=item REG_DWORD
+
+If the C<DualBinVals()> option is on, then the value is returned
+as a scalar containing both a string and a number [much like
+the C<$!> variable -- see the L<SetDualVar> module for more
+information] where the number part is the "unpacked" value.
+Use the returned value in a numeric context to access this part
+of the value. For example:
+
+ $num= 0 + $Registry->{"CUser/Console//ColorTable01"};
+
+If the C<DWordsToHex()> option is off, the string part of the
+returned value is a packed, 4-byte string [use C<unpack("L",$value)>
+to get the numeric value.
+
+If C<DWordsToHex()> is on, the string part of the returned value is
+a 10-character hex strings [with leading "0x"]. You can use
+C<hex($value)> to get the numeric value.
+
+Note that C<SetValue()> will properly understand each of these
+returned value formats no matter how C<DualBinVals()> is set.
+
+=back
+
+=item ValueNames
+
+=item @names= $key->ValueNames
+
+Returns the list of value names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter prepended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyNames
+
+=item @key_names= $key->SubKeyNames
+
+Returns the list of subkey names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter appended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyClasses
+
+=item @classes= $key->SubKeyClasses
+
+Returns the list of classes for subkeys stored directly in a
+Registry key. The classes are returned in the same order as
+the subkey names returned by C<SubKeyNames()>.
+
+=item SubKeyTimes
+
+=item @times= $key->SubKeyTimes
+
+Returns the list of last-modified times for subkeys stored
+directly in a Registry key. The times are returned in the same
+order as the subkey names returned by C<SubKeyNames()>. Each
+time is a C<FILETIME> structure packed into a Perl string.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item MemberNames
+
+=item @members= $key->MemberNames
+
+Returns the list of subkey names and value names stored directly
+in a Registry key. Subkey names have a delimiter appended to the
+end and value names have a delimiter prepended to the front.
+
+Note that a value name could end in a delimiter [or could be C<"">
+so that the member name returned is just a delimiter] so the
+presence or absence of the leading delimiter is what should be
+used to determine whether a particular name is for a subkey or a
+value, not the presence or absence of a trailing delimiter.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item Information
+
+=item %info= $key->Information
+
+=item @items= $key->Information( @itemNames );
+
+Returns the following information about a Registry key:
+
+=over
+
+=item LastWrite
+
+A C<FILETIME> structure indicating when the key was last modified
+and packed into a Perl string.
+
+=item CntSubKeys
+
+The number of subkeys stored directly in this key.
+
+=item CntValues
+
+The number of values stored directly in this key.
+
+=item SecurityLen
+
+The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR>
+associated with the Registry key.
+
+=item MaxValDataLen
+
+The length [in bytes] of the longest value data associated with
+a value stored in this key.
+
+=item MaxSubKeyLen
+
+The length [in chars] of the longest subkey name associated with
+a subkey stored in this key.
+
+=item MaxSubClassLen
+
+The length [in chars] of the longest class name associated with
+a subkey stored directly in this key.
+
+=item MaxValNameLen
+
+The length [in chars] of the longest value name associated with
+a value stored in this key.
+
+=back
+
+With no arguments, returns a hash [not a reference to a hash] where
+the keys are the names for the items given above and the values
+are the information describe above. For example:
+
+ %info= ( "CntValues" => 25, # Key contains 25 values.
+ "MaxValNameLen" => 20, # One of which has a 20-char name.
+ "MaxValDataLen" => 42, # One of which has a 42-byte value.
+ "CntSubKeys" => 1, # Key has 1 immediate subkey.
+ "MaxSubKeyLen" => 13, # One of which has a 12-char name.
+ "MaxSubClassLen" => 0, # All of which have class names of "".
+ "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes.
+ "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA"
+ # Key was last modifed 1998/06/01 16:29:32 GMT
+ );
+
+With arguments, each one must be the name of a item given above.
+The return value is the information associated with the listed
+names. In other words:
+
+ return $key->Information( @names );
+
+returns the same list as:
+
+ %info= $key->Information;
+ return @info{@names};
+
+=item Delimiter
+
+=item $oldDelim= $key->Delimiter
+
+=item $oldDelim= $key->Delimiter( $newDelim )
+
+Gets and possibly changes the delimiter used for this object. The
+delimiter is appended to subkey names and prepended to value names
+in many return values. It is also used when parsing keys passed
+to tied hashes.
+
+The delimiter defaults to backslash (C<'\\'>) but is inherited from
+the object used to create a new object and can be specified by an
+option when a new object is created.
+
+=item Handle
+
+=item $handle= $key->Handle
+
+Returns the raw C<HKEY> handle for the associated Registry key as
+an integer value. This value can then be used to Reg*() calls
+from I<Win32API::Registry>. However, it is usually easier to just
+call the I<Win32API::Registry> calls directly via:
+
+ $key->RegNotifyChangeKeyValue( ... );
+
+For the virtual root of the local or a remote Registry,
+C<Handle()> return C<"NONE">.
+
+=item Path
+
+=item $path= $key->Path
+
+Returns a string describing the path of key names to this
+Registry key. The string is built so that if it were passed
+to C<$Registry->Open()>, it would reopen the same Registry key
+[except in the rare case where one of the key names contains
+C<$key->Delimiter>].
+
+=item Machine
+
+=item $computerName= $key->Machine
+
+Returns the name of the computer [or "machine"] on which this Registry
+key resides. Returns C<""> for local Registry keys.
+
+=item Access
+
+Returns the numeric value of the bit mask used to specify the
+types of access requested when this Registry key was opened. Can
+be compared to C<KEY_*> values.
+
+=item OS_Delimiter
+
+Returns the delimiter used by the operating system's RegOpenKeyEx()
+call. For Win32, this is always backslash (C<"\\">).
+
+=item Roots
+
+Returns the mapping from root key names like C<"LMachine"> to their
+associated C<HKEY_*> constants. Primarily for internal use and
+subject to change.
+
+=item Tie
+
+=item $key->Tie( \%hash );
+
+Ties the referenced hash to that Registry key. Pretty much the
+same as
+
+ tie %hash, ref($key), $key;
+
+Since C<ref($key)> is the class [package] to tie the hash to and
+C<TIEHASH()> just returns its argument, C<$key>, [without calling
+C<new()>] when it sees that it is already a blessed object.
+
+=item TiedRef
+
+=item $TiedHashRef= $hash_or_obj_ref->TiedRef
+
+For a simple object, returns a reference to a hash tied to the
+object. Used to promote a simple object into a combined object
+and hash ref.
+
+If already a reference to a tied hash [that is also an object],
+it just returns itself [C<$ref == $ref->TiedRef>].
+
+Mostly used internally.
+
+=item ArrayValues
+
+=item $oldBool= $key->ArrayValues
+
+=item $oldBool= $key->ArrayValues( $newBool )
+
+Gets the current setting of the C<ArrayValues> option and possibly
+turns it on or off.
+
+When off, Registry values fetched via a tied hash are returned as
+just a value scalar [the same as C<GetValue()> in a scalar context].
+When on, they are returned as a reference to an array containing
+the value data as the C<[0]> element and the data type as the C<[1]>
+element.
+
+=item TieValues
+
+=item $oldBool= TieValues
+
+=item $oldBool= TieValues( $newBool )
+
+Gets the current setting of the C<TieValues> option and possibly
+turns it on or off.
+
+Turning this option on is not yet supported in this release of
+I<Win32::TieRegistry>. In a future release, turning this option
+on will cause Registry values returned from a tied hash to be
+a tied array that you can use to modify the value in the Registry.
+
+=item FastDelete
+
+=item $oldBool= $key->FastDelete
+
+=item $oldBool= $key->FastDelete( $newBool )
+
+Gets the current setting of the C<FastDelete> option and possibly
+turns it on or off.
+
+When on, successfully deleting a Registry key [via a tied hash]
+simply returns C<1>.
+
+When off, successfully deleting a Registry key [via a tied hash
+and not in a void context] returns a reference to a hash that
+contains the values present in the key when it was deleted. This
+hash is just like that returned when referencing the key before it
+was deleted except that it is an ordinary hash, not one tied to
+the I<Win32::TieRegistry> package.
+
+Note that deleting either a Registry key or value via a tied hash
+I<in a void context> prevents any overhead in trying to build an
+appropriate return value.
+
+Note that deleting a Registry I<value> via a tied hash [not in
+a void context] returns the value data even if <FastDelete> is on.
+
+=item SplitMultis
+
+=item $oldBool= $key->SplitMultis
+
+=item $oldBool= $key->SplitMultis( $newBool )
+
+Gets the current setting of the C<SplitMultis> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_MULTI_SZ> are returned as
+a reference to an array of strings. See C<GetValue()> for more
+information.
+
+=item DWordsToHex
+
+=item $oldBool= $key->DWordsToHex
+
+=item $oldBool= $key->DWordsToHex( $newBool )
+
+Gets the current setting of the C<DWordsToHex> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_DWORD> are returned as a hex
+string with leading C<"0x"> and longer than 4 characters. See
+C<GetValue()> for more information.
+
+=item FixSzNulls
+
+=item $oldBool= $key->FixSzNulls
+
+=item $oldBool= $key->FixSzNulls( $newBool )
+
+Gets the current setting of the C<FixSzNulls> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have
+trailing C<'\0'>s added before they are set and stripped before
+they are returned. See C<GetValue()> and C<SetValue()> for more
+information.
+
+=item DualTypes
+
+=item $oldBool= $key->DualTypes
+
+=item $oldBool= $key->DualTypes( $newBool )
+
+Gets the current setting of the C<DualTypes> option and possibly
+turns it on or off.
+
+If on, data types are returned as a combined numeric/string value
+holding both the numeric value of a C<REG_*> constant and the
+string value of the constant's name. See C<GetValue()> for
+more information.
+
+=item DualBinVals
+
+=item $oldBool= $key->DualBinVals
+
+=item $oldBool= $key->DualBinVals( $newBool )
+
+Gets the current setting of the C<DualBinVals> option and possibly
+turns it on or off.
+
+If on, Registry value data of type C<REG_BINARY> and no more than
+4 bytes long and Registry values of type C<REG_DWORD> are returned
+as a combined numeric/string value where the numeric value is the
+"unpacked" binary value as returned by:
+
+ hex reverse unpack( "h*", $valData )
+
+on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)>
+on a "big-endian" computer if this module is ever ported to one.]
+
+See C<GetValue()> for more information.
+
+=item GetOptions
+
+=item @oldOptValues= $key->GetOptions( @optionNames )
+
+=item $refHashOfOldOpts= $key->GetOptions()
+
+=item $key->GetOptions( \%hashForOldOpts )
+
+Returns the current setting of any of the following options:
+
+ Delimiter FixSzNulls DWordsToHex
+ ArrayValues SplitMultis DualBinVals
+ TieValues FastDelete DualTypes
+
+Pass in one or more of the above names (as strings) to get back
+an array of the corresponding current settings in the same order:
+
+ my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter");
+
+Pass in no arguments to get back a reference to a hash where
+the above option names are the keys and the values are
+the corresponding current settings for each option:
+
+ my $href= $key->GetOptions();
+ my $delim= $href->{Delimiter};
+
+Pass in a single reference to a hash to have the above key/value
+pairs I<added> to the referenced hash. For this case, the
+return value is the original object so further methods can be
+chained after the call to GetOptions:
+
+ my %oldOpts;
+ $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" );
+
+=item SetOptions
+
+=item @oldOpts= $key->SetOptions( optNames=>$optValue,... )
+
+Changes the current setting of any of the following options,
+returning the previous setting(s):
+
+ Delimiter FixSzNulls DWordsToHex AllowLoad
+ ArrayValues SplitMultis DualBinVals AllowSave
+ TieValues FastDelete DualTypes
+
+For C<AllowLoad> and C<AllowSave>, instead of the previous
+setting, C<SetOptions> returns whether or not the change was
+successful.
+
+In a scalar context, returns only the last item. The last
+option can also be specified as C<"ref"> or C<"r"> [which doesn't
+need to be followed by a value] to allow chaining:
+
+ $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...)
+
+=item SetValue
+
+=item $okay= $key->SetValue( $ValueName, $ValueData );
+
+=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType );
+
+Adds or replaces a Registry value. Returns a true value if
+successfully, false otherwise.
+
+C<$ValueName> is the name of the value to add or replace and
+should I<not> have a delimiter prepended to it. Case is ignored.
+
+C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise,
+it should be one the C<REG_*> constants.
+
+C<$ValueData> is the data to be stored in the value, probably packed
+into a Perl string. Other supported formats for value data are
+listed below for each posible C<$ValueType>.
+
+=over
+
+=item REG_SZ or REG_EXPAND_SZ
+
+The only special processing for these values is the addition of
+the required trailing C<'\0'> if it is missing. This can be
+turned off by disabling the C<FixSzNulls> option.
+
+=item REG_MULTI_SZ
+
+These values can also be specified as a reference to a list of
+strings. For example, the following two lines are equivalent:
+
+ $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" );
+ $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" );
+
+Note that if the required two trailing nulls (C<"\000\000">) are
+missing, then this release of C<SetValue()> will I<not> add them.
+
+=item REG_DWORD
+
+These values can also be specified as a hex value with the leading
+C<"0x"> included and totaling I<more than> 4 bytes. These will be
+packed into a 4-byte string via:
+
+ $data= pack( "L", hex($data) );
+
+=item REG_BINARY
+
+This value type is listed just to emphasize that no alternate
+format is supported for it. In particular, you should I<not> pass
+in a numeric value for this type of data. C<SetValue()> cannot
+distinguish such from a packed string that just happens to match
+a numeric value and so will treat it as a packed string.
+
+=back
+
+An alternate calling format:
+
+ $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] );
+
+[two arguments, the second of which is a reference to an array
+containing the value data and value type] is supported to ease
+using tied hashes with C<SetValue()>.
+
+=item CreateKey
+
+=item $newKey= $key->CreateKey( $subKey );
+
+=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } );
+
+Creates a Registry key or just updates attributes of one. Calls
+C<RegCreateKeyEx()> then, if it succeeded, creates an object
+associated with the [possibly new] subkey.
+
+C<$subKey> is the name of a subkey [or a path to one] to be
+created or updated. It can also be a reference to an array
+containing a list of subkey names.
+
+The second argument, if it exists, should be a reference to a
+hash specifying options either to be passed to C<RegCreateKeyEx()>
+or to be used when creating the associated object. The following
+items are the supported keys for this options hash:
+
+=over
+
+=item Delimiter
+
+Specifies the delimiter to be used to parse C<$subKey> and to be
+used in the new object. Defaults to C<$key->Delimiter>.
+
+=item Access
+
+Specifies the types of access requested when the subkey is opened.
+Should be a numeric bit mask that combines one or more C<KEY_*>
+constant values.
+
+=item Class
+
+The name to assign as the class of the new or updated subkey.
+Defaults to C<""> as we have never seen a use for this information.
+
+=item Disposition
+
+Lets you specify a reference to a scalar where, upon success, will be
+stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()>
+depending on whether a new key was created or an existing key was
+opened.
+
+If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)>
+then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric
+value stored in the referenced scalar.
+
+If the C<DualTypes> option is enabled, then in addition to the
+numeric value described above, the referenced scalar will also
+have a string value equal to either C<"REG_CREATED_NEW_KEY"> or
+C<"REG_OPENED_EXISTING_KEY">, as appropriate.
+
+=item Security
+
+Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a
+Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more
+information.
+
+=item Volatile
+
+If true, specifies that the new key should be volatile, that is,
+stored only in memory and not backed by a hive file [and not saved
+if the computer is rebooted]. This option is ignored under
+Windows 95. Specifying C<Volatile=E<gt>1> is the same as
+specifying C<Options=E<gt>REG_OPTION_VOLATILE>.
+
+=item Backup
+
+If true, specifies that the new key should be opened for
+backup/restore access. The C<Access> option is ignored. If the
+calling process has enabled C<"SeBackupPrivilege">, then the
+subkey is opened with C<KEY_READ> access as the C<"LocalSystem">
+user which should have access to all subkeys. If the calling
+process has enabled C<"SeRestorePrivilege">, then the subkey is
+opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which
+should have access to all subkeys.
+
+This option is ignored under Windows 95. Specifying C<Backup=E<gt>1>
+is the same as specifying C<Options=E<gt>REG_OPTION_BACKUP_RESTORE>.
+
+=item Options
+
+Lets you specify options to the C<RegOpenKeyEx()> call. The value
+for this option should be a numeric value combining zero or more
+of the C<REG_OPTION_*> bit masks. You may with to used the
+C<Volatile> and/or C<Backup> options instead of this one.
+
+=back
+
+=item StoreKey
+
+=item $newKey= $key->StoreKey( $subKey, \%Contents );
+
+Primarily for internal use.
+
+Used to create or update a Registry key and any number of subkeys
+or values under it or its subkeys.
+
+C<$subKey> is the name of a subkey to be created [or a path of
+subkey names separated by delimiters]. If that subkey already
+exists, then it is updated.
+
+C<\%Contents> is a reference to a hash containing pairs of
+value names with value data and/or subkey names with hash
+references similar to C<\%Contents>. Each of these cause
+a value or subkey of C<$subKey> to be created or updated.
+
+If C<$Contents{""}> exists and is a reference to a hash, then
+it used as the options argument when C<CreateKey()> is called
+for C<$subKey>. This allows you to specify ...
+
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+
+=item Load
+
+=item $newKey= $key->Load( $file )
+
+=item $newKey= $key->Load( $file, $newSubKey )
+
+=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } )
+
+=item $newKey= $key->Load( $file, { Option=>OptVal... } )
+
+Loads a hive file into a Registry. That is, creates a new subkey
+and associates a hive file with it.
+
+C<$file> is a hive file, that is a file created by calling
+C<RegSaveKey()>. The C<$file> path is interpreted relative to
+C<%SystemRoot%/System32/config> on the machine where C<$key>
+resides.
+
+C<$newSubKey> is the name to be given to the new subkey. If
+C<$newSubKey> is specified, then C<$key> must be
+C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer
+or a remote computer and C<$newSubKey> should not contain any
+occurrences of either the delimiter or the OS delimiter.
+
+If C<$newSubKey> is not specified, then it is as if C<$key>
+was C<$Registry-E<gt>{LMachine}> and C<$newSubKey> is
+C<"PerlTie:999"> where C<"999"> is actually a sequence number
+incremented each time this process calls C<Load()>.
+
+You can specify as the last argument a reference to a hash
+containing options. You can specify the same options that you
+can specify to C<Open()>. See C<Open()> for more information on
+those. In addition, you can specify the option C<"NewSubKey">.
+The value of this option is interpretted exactly as if it was
+specified as the C<$newSubKey> parameter and overrides the
+C<$newSubKey> if one was specified.
+
+The hive is automatically unloaded when the returned object
+[C<$newKey>] is destroyed. Registry key objects opened within
+the hive will keep a reference to the C<$newKey> object so that
+it will not be destroyed before these keys are closed.
+
+=item UnLoad
+
+=item $okay= $key->UnLoad
+
+Unloads a hive that was loaded via C<Load()>. Cannot unload other
+hives. C<$key> must be the return from a previous call to C<Load()>.
+C<$key> is closed and then the hive is unloaded.
+
+=item AllowSave
+
+=item $okay= AllowSave( $bool )
+
+Enables or disables the C<"ReBackupPrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegSaveKey()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=item AllowLoad
+
+=item $okay= AllowLoad( $bool )
+
+Enables or disables the C<"ReRestorePrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegLoadKey()>, C<RegUnLoadKey()>,
+C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and
+C<UnLoad()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=back
+
+=head2 Exports [C<use> and C<import()>]
+
+To have nothing imported into your package, use something like:
+
+ use Win32::TieRegistry 0.20 ();
+
+which would verify that you have at least version 0.20 but wouldn't
+call C<import()>. The F<Changes> file can be useful in figuring out
+which, if any, prior versions of I<Win32::TieRegistry> you want to
+support in your script.
+
+The code
+
+ use Win32::TieRegistry;
+
+imports the variable C<$Registry> into your package and sets it
+to be a reference to a hash tied to a copy of the master Registry
+virtual root object with the default options. One disadvantage
+to this "default" usage is that Perl does not support checking
+the module version when you use it.
+
+Alternately, you can specify a list of arguments on the C<use>
+line that will be passed to the C<Win32::TieRegistry->import()>
+method to control what items to import into your package. These
+arguments fall into the following broad categories:
+
+=over
+
+=item Import a reference to a hash tied to a Registry virtual root
+
+You can request that a scalar variable be imported (possibly)
+and set to be a reference to a hash tied to a Registry virtual root
+using any of the following types of arguments or argument pairs:
+
+=over
+
+=item "TiedRef", '$scalar'
+
+=item "TiedRef", '$pack::scalar'
+
+=item "TiedRef", 'scalar'
+
+=item "TiedRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$scalar'
+
+=item '$pack::scalar'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports. Note that the
+scalar name cannot be "RegObj" here.
+
+=item "TiedRef", \$scalar
+
+=item \$scalar
+
+These versions don't import anything but set the referenced C<$scalar>.
+
+=back
+
+=item Import a hash tied to the Registry virtual root
+
+You can request that a hash variable be imported (possibly)
+and tied to a Registry virtual root using any of the following
+types of arguments or argument pairs:
+
+=over
+
+=item "TiedHash", '%hash'
+
+=item "TiedHash", '%pack::hash'
+
+=item "TiedHash", 'hash'
+
+=item "TiedHash", 'pack::hash'
+
+All of the above import a hash named C<%hash> into your package
+(or the package named "pack") and then sets it.
+
+=item '%hash'
+
+=item '%pack::hash'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports.
+
+=item "TiedHash", \%hash
+
+=item \%hash
+
+These versions don't import anything but set the referenced C<%hash>.
+
+=back
+
+=item Import a Registry virtual root object
+
+You can request that a scalar variable be imported (possibly)
+and set to be a Registry virtual root object using any of the
+following types of arguments or argument pairs:
+
+=over
+
+=item "ObjectRef", '$scalar'
+
+=item "ObjectRef", '$pack::scalar'
+
+=item "ObjectRef", 'scalar'
+
+=item "ObjectRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$RegObj'
+
+This is equivalent to the previous items for backward compatibility.
+
+=item "ObjectRef", \$scalar
+
+This version doesn't import anything but sets the referenced C<$scalar>.
+
+=back
+
+=item Import constant(s) exported by I<Win32API::Registry>
+
+You can list any constants that are exported by I<Win32API::Registry>
+to have them imported into your package. These constants have names
+starting with "KEY_" or "REG_" (or even "HKEY_").
+
+You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to
+import a whole set of constants.
+
+See I<Win32API::Registry> documentation for more information.
+
+=item Options
+
+You can list any option names that can be listed in the C<SetOptions()>
+method call, each folowed by the value to use for that option.
+A Registry virtual root object is created, all of these options are
+set for it, then each variable to be imported/set is associated with
+this object.
+
+In addition, the following special options are supported:
+
+=over
+
+=item ExportLevel
+
+Whether to import variables into your package or some
+package that uses your package. Defaults to the value of
+C<$Exporter::ExportLevel> and has the same meaning. See
+the L<Exporter> module for more information.
+
+=item ExportTo
+
+The name of the package to import variables and constants into.
+Overrides I<ExportLevel>.
+
+=back
+
+=back
+
+=head3 Specifying constants in your Perl code
+
+This module was written with a strong emphasis on the convenience of
+the module user. Therefore, most places where you can specify a
+constant like C<REG_SZ()> also allow you to specify a string
+containing the name of the constant, C<"REG_SZ">. This is convenient
+because you may not have imported that symbolic constant.
+
+Perl also emphasizes programmer convenience so the code C<REG_SZ>
+can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal.
+Note that using C<&REG_SZ> (as we've seen in much Win32 Perl code)
+is not a good idea since it passes the current C<@_> to the
+C<constant()> routine of the module which, at the least, can give
+you a warning under B<-w>.
+
+Although greatly a matter of style, the "safest" practice is probably
+to specifically list all constants in the C<use Win32::TieRegistry>
+statement, specify C<use strict> [or at least C<use strict qw(subs)>],
+and use bare constant names when you want the numeric value. This will
+detect mispelled constant names at compile time.
+
+ use strict;
+ my $Registry;
+ use Win32::TieRegistry 0.20 (
+ TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1,
+ SplitMultis => 1, AllowLoad => 1,
+ qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS ),
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+If you don't want to C<use strict qw(subs)>, the second safest practice
+is similar to the above but use the C<REG_SZ()> form for constants
+when possible and quoted constant names when required. Note that
+C<qw()> is a form of quoting.
+
+ use Win32::TieRegistry 0.20 qw(
+ TiedRef $Registry
+ Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1
+ REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD() ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+The examples in this document mostly use quoted constant names
+(C<"REG_SZ">) since that works regardless of which constants
+you imported and whether or not you have C<use strict> in your
+script. It is not the best choice for you to use for real
+scripts (vs. examples) because it is less efficient and is not
+supported by most other similar modules.
+
+=head1 SUMMARY
+
+Most things can be done most easily via tied hashes. Skip down to the
+the L<Tied Hashes Summary> to get started quickly.
+
+=head2 Objects Summary
+
+Here are quick examples that document the most common functionality
+of all of the method functions [except for a few almost useless ones].
+
+ # Just another way of saying Open():
+ $key= new Win32::TieRegistry "LMachine\\Software\\",
+ { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" };
+
+ # Open a Registry key:
+ $subKey= $key->Open( "SubKey/SubSubKey/",
+ { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } );
+
+ # Connect to a remote Registry key:
+ $remKey= $Registry->Connect( "MachineName", "LMachine/",
+ { Access=>KEY_READ, Delimiter=>"/" } );
+
+ # Get value data:
+ $valueString= $key->GetValue("ValueName");
+ ( $valueString, $valueType )= $key->GetValue("ValueName");
+
+ # Get list of value names:
+ @valueNames= $key->ValueNames;
+
+ # Get list of subkey names:
+ @subKeyNames= $key->SubKeyNames;
+
+ # Get combined list of value names (with leading delimiters)
+ # and subkey names (with trailing delimiters):
+ @memberNames= $key->MemberNames;
+
+ # Get all information about a key:
+ %keyInfo= $key->Information;
+ # keys(%keyInfo)= qw( Class LastWrite SecurityLen
+ # CntSubKeys MaxSubKeyLen MaxSubClassLen
+ # CntValues MaxValNameLen MaxValDataLen );
+
+ # Get selected information about a key:
+ ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" );
+
+ # Get and/or set delimiter:
+ $delim= $key->Delimiter;
+ $oldDelim= $key->Delimiter( $newDelim );
+
+ # Get "path" for an open key:
+ $path= $key->Path;
+ # For example, "/CUser/Control Panel/Mouse/"
+ # or "//HostName/LMachine/System/DISK/".
+
+ # Get name of machine where key is from:
+ $mach= $key->Machine;
+ # Will usually be "" indicating key is on local machine.
+
+ # Control different options (see main documentation for descriptions):
+ $oldBool= $key->ArrayValues( $newBool );
+ $oldBool= $key->FastDelete( $newBool );
+ $oldBool= $key->FixSzNulls( $newBool );
+ $oldBool= $key->SplitMultis( $newBool );
+ $oldBool= $key->DWordsToHex( $newBool );
+ $oldBool= $key->DualBinVals( $newBool );
+ $oldBool= $key->DualTypes( $newBool );
+ @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0,
+ Delimiter=>"/", AllowLoad=>1, AllowSave=>1 );
+ @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls );
+
+ # Add or set a value:
+ $key->SetValue( "ValueName", $valueDataString );
+ $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" );
+
+ # Add or set a key:
+ $key->CreateKey( "SubKeyName" );
+ $key->CreateKey( "SubKeyName",
+ { Access=>"KEY_ALL_ACCESS", Class=>"ClassName",
+ Delimiter=>"/", Volatile=>1, Backup=>1 } );
+
+ # Load an off-line Registry hive file into the on-line Registry:
+ $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" );
+ $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName",
+ { Access=>"KEY_READ" } );
+ # Unload a Registry hive file loaded via the Load() method:
+ $newKey->UnLoad;
+
+ # (Dis)Allow yourself to load Registry hive files:
+ $success= $Registry->AllowLoad( $bool );
+
+ # (Dis)Allow yourself to save a Registry key to a hive file:
+ $success= $Registry->AllowSave( $bool );
+
+ # Save a Registry key to a new hive file:
+ $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] );
+
+=head3 Other Useful Methods
+
+See I<Win32API::Registry> for more information on these methods.
+These methods are provided for coding convenience and are
+identical to the I<Win32API::Registry> functions except that these
+don't take a handle to a Registry key, instead getting the handle
+from the invoking object [C<$key>].
+
+ $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc );
+ $key->RegLoadKey( $sSubKeyName, $sPathToFile );
+ $key->RegNotifyChangeKeyValue(
+ $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync );
+ $key->RegQueryMultipleValues(
+ $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer );
+ $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile );
+ $key->RegRestoreKey( $sPathToFile, $iFlags );
+ $key->RegSetKeySecurity( $iSecInfo, $sSecDesc );
+ $key->RegUnLoadKey( $sSubKeyName );
+
+=head2 Tied Hashes Summary
+
+For fast learners, this may be the only section you need to read.
+Always append one delimiter to the end of each Registry key name
+and prepend one delimiter to the front of each Registry value name.
+
+=head3 Opening keys
+
+ use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 );
+ $Registry->Delimiter("/"); # Set delimiter to "/".
+ $swKey= $Registry->{"LMachine/Software/"};
+ $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"};
+ $userKey= $Registry->
+ {"CUser/Software/Microsoft/Windows/CurrentVersion/"};
+ $remoteKey= $Registry->{"//HostName/LMachine/"};
+
+=head3 Reading values
+
+ $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files"
+ $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21.
+
+ $winKey->ArrayValues(1);
+ ( $devPath, $type )= $winKey->{"/DevicePath"};
+ # $devPath eq "%SystemRoot%\\inf"
+ # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed]
+ # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>]
+
+=head3 Setting values
+
+ $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows";
+ # Simple. Assumes data type of REG_SZ.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ];
+ # "\x00" and "\0" used to mark ends of each string and end of list.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ];
+ # Alternate method that is easier to read.
+
+ $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}=
+ [ pack("L",0), "REG_DWORD" ];
+ $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ];
+ $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ];
+
+=head3 Adding keys
+
+ $swKey->{"FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+=head3 Listing all subkeys and values
+
+ @members= keys( %{$swKey} );
+ @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @subKeys= ( "/", "/EditFlags" );
+ @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" );
+
+=head3 Deleting values or keys with no subkeys
+
+ $oldValue= delete $userKey->{"Explorer/Tips//Next"};
+
+ $oldValues= delete $userKey->{"Explorer/Tips/"};
+ # $oldValues will be reference to hash containing deleted keys values.
+
+=head3 Closing keys
+
+ undef $swKey; # Explicit way to close a key.
+ $winKey= "Anything else"; # Implicitly closes a key.
+ exit 0; # Implicitly closes all keys.
+
+=head2 Tie::Registry
+
+This module was originally called I<Tie::Registry>. Changing code
+that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial
+as the module name should only be mentioned once, in the C<use>
+line. However, finding all of the places that used I<Tie::Registry>
+may not be completely trivial so we have included F<Tie/Registry.pm>
+which you can install to provide backward compatibility.
+
+=head1 AUTHOR
+
+Tye McQueen. See http://www.metronet.com/~tye/ or e-mail
+tye@metronet.com with bug reports.
+
+=head1 SEE ALSO
+
+I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>,
+C<KEY_*>, C<REG_*> [required].
+
+I<Win32::WinError> - Defines C<ERROR_*> values [optional].
+
+L<SetDualVar> - For returning C<REG_*> values as combined
+string/integer values [optional].
+
+=head1 BUGS
+
+Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in
+strange and subtle ways.
+
+Using I<Win32::TieRegistry> with versions of Perl prior to 5.005
+can be tricky or impossible. Most notes about this have been
+removed from the documentation (they get rather complicated
+and confusing). This includes references to C<$^E> perhaps not
+being meaningful.
+
+Because Perl hashes are case sensitive, certain lookups are also
+case sensistive. In particular, the root keys ("Classes", "CUser",
+"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*)
+must always be entered without changing between upper and lower
+case letters. Also, the special rule for matching subkey names
+that contain the user-selected delimiter only works if case is
+matched. All other key name and value name lookups should be case
+insensitive because the underlying Reg*() calls ignore case.
+
+Information about each key is cached when using a tied hash.
+This cache is not flushed nor updated when changes are made,
+I<even when the same tied hash is used> to make the changes.
+
+Current implementations of Perl's "global destruction" phase can
+cause objects returned by C<Load()> to be destroyed while keys
+within the hive are still open, if the objects still exist when
+the script starts to exit. When this happens, the automatic
+C<UnLoad()> will report a failure and the hive will remain loaded
+in the Registry.
+
+Trying to C<Load()> a hive file that is located on a remote network
+share may silently delete all data from the hive. This is a bug
+in the Win32 APIs, not any Perl code or modules. This module does
+not try to protect you from this bug.
+
+There is no test suite.
+
+=head1 FUTURE DIRECTIONS
+
+The following items are desired by the author and may appear in a
+future release of this module.
+
+=over
+
+=item TieValues option
+
+Currently described in main documentation but no yet implemented.
+
+=item AutoRefresh option
+
+Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash
+caches up-to-date even when other programs make changes.
+
+=item Error options
+
+Allow the user to have unchecked calls (calls in a "void context")
+to automatically report errors via C<warn> or C<die>.
+
+For complex operations, such a copying an entire subtree, provide
+access to detailed information about errors (and perhaps some
+warnings) that were encountered. Let the user control whether
+the complex operation continues in spite of errors.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1999 - 2006 Tye McQueen.
+
+Some parts copyright 2007 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Autoload not currently supported by Perl under Windows.
diff --git a/Master/tlpkg/tlperl/lib/Win32API/File.pm b/Master/tlpkg/tlperl/lib/Win32API/File.pm
new file mode 100644
index 00000000000..a6473520ae0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32API/File.pm
@@ -0,0 +1,3035 @@
+# File.pm -- Low-level access to Win32 file/dir functions/constants.
+
+package Win32API::File;
+
+use strict;
+use integer;
+use Carp;
+use Config qw( %Config );
+use Fcntl qw( O_RDONLY O_RDWR O_WRONLY O_APPEND O_BINARY O_TEXT );
+use vars qw( $VERSION @ISA );
+use vars qw( @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS );
+
+$VERSION= '0.1101';
+
+use base qw( Exporter DynaLoader Tie::Handle IO::File );
+
+# Math::BigInt optimizations courtesy of Tels
+my $_64BITINT;
+BEGIN {
+ $_64BITINT = defined($Config{use64bitint}) &&
+ ($Config{use64bitint} eq 'define');
+
+ require Math::BigInt unless $_64BITINT;
+}
+
+my $THIRTY_TWO = $_64BITINT ? 32 : Math::BigInt->new(32);
+
+my $FFFFFFFF = $_64BITINT ? 0xFFFFFFFF : Math::BigInt->new(0xFFFFFFFF);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( attrLetsToBits createFile
+ fileConstant fileLastError getLogicalDrives
+ CloseHandle CopyFile CreateFile
+ DefineDosDevice DeleteFile DeviceIoControl
+ FdGetOsFHandle GetDriveType GetFileAttributes GetFileType
+ GetHandleInformation GetLogicalDrives GetLogicalDriveStrings
+ GetOsFHandle GetVolumeInformation IsRecognizedPartition
+ IsContainerPartition MoveFile MoveFileEx
+ OsFHandleOpen OsFHandleOpenFd QueryDosDevice
+ ReadFile SetErrorMode SetFilePointer
+ SetHandleInformation WriteFile GetFileSize
+ getFileSize setFilePointer GetOverlappedResult)],
+ FuncA => [qw(
+ CopyFileA CreateFileA DefineDosDeviceA
+ DeleteFileA GetDriveTypeA GetFileAttributesA GetLogicalDriveStringsA
+ GetVolumeInformationA MoveFileA MoveFileExA
+ QueryDosDeviceA )],
+ FuncW => [qw(
+ CopyFileW CreateFileW DefineDosDeviceW
+ DeleteFileW GetDriveTypeW GetFileAttributesW GetLogicalDriveStringsW
+ GetVolumeInformationW MoveFileW MoveFileExW
+ QueryDosDeviceW )],
+ Misc => [qw(
+ CREATE_ALWAYS CREATE_NEW FILE_BEGIN
+ FILE_CURRENT FILE_END INVALID_HANDLE_VALUE
+ OPEN_ALWAYS OPEN_EXISTING TRUNCATE_EXISTING )],
+ DDD_ => [qw(
+ DDD_EXACT_MATCH_ON_REMOVE DDD_RAW_TARGET_PATH
+ DDD_REMOVE_DEFINITION )],
+ DRIVE_ => [qw(
+ DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE
+ DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM
+ DRIVE_RAMDISK )],
+ FILE_ => [qw(
+ FILE_READ_DATA FILE_LIST_DIRECTORY
+ FILE_WRITE_DATA FILE_ADD_FILE
+ FILE_APPEND_DATA FILE_ADD_SUBDIRECTORY
+ FILE_CREATE_PIPE_INSTANCE FILE_READ_EA
+ FILE_WRITE_EA FILE_EXECUTE
+ FILE_TRAVERSE FILE_DELETE_CHILD
+ FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES
+ FILE_ALL_ACCESS FILE_GENERIC_READ
+ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE )],
+ FILE_ATTRIBUTE_ => [qw(
+ INVALID_FILE_ATTRIBUTES
+ FILE_ATTRIBUTE_DEVICE FILE_ATTRIBUTE_DIRECTORY
+ FILE_ATTRIBUTE_ENCRYPTED FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
+ FILE_ATTRIBUTE_REPARSE_POINT FILE_ATTRIBUTE_SPARSE_FILE
+ FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED
+ FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL
+ FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY
+ FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY )],
+ FILE_FLAG_ => [qw(
+ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_DELETE_ON_CLOSE
+ FILE_FLAG_NO_BUFFERING FILE_FLAG_OVERLAPPED
+ FILE_FLAG_POSIX_SEMANTICS FILE_FLAG_RANDOM_ACCESS
+ FILE_FLAG_SEQUENTIAL_SCAN FILE_FLAG_WRITE_THROUGH
+ FILE_FLAG_OPEN_REPARSE_POINT )],
+ FILE_SHARE_ => [qw(
+ FILE_SHARE_DELETE FILE_SHARE_READ FILE_SHARE_WRITE )],
+ FILE_TYPE_ => [qw(
+ FILE_TYPE_CHAR FILE_TYPE_DISK FILE_TYPE_PIPE
+ FILE_TYPE_UNKNOWN )],
+ FS_ => [qw(
+ FS_CASE_IS_PRESERVED FS_CASE_SENSITIVE
+ FS_UNICODE_STORED_ON_DISK FS_PERSISTENT_ACLS
+ FS_FILE_COMPRESSION FS_VOL_IS_COMPRESSED )],
+ FSCTL_ => [qw(
+ FSCTL_SET_REPARSE_POINT FSCTL_GET_REPARSE_POINT
+ FSCTL_DELETE_REPARSE_POINT )],
+ HANDLE_FLAG_ => [qw(
+ HANDLE_FLAG_INHERIT HANDLE_FLAG_PROTECT_FROM_CLOSE )],
+ IOCTL_STORAGE_ => [qw(
+ IOCTL_STORAGE_CHECK_VERIFY IOCTL_STORAGE_MEDIA_REMOVAL
+ IOCTL_STORAGE_EJECT_MEDIA IOCTL_STORAGE_LOAD_MEDIA
+ IOCTL_STORAGE_RESERVE IOCTL_STORAGE_RELEASE
+ IOCTL_STORAGE_FIND_NEW_DEVICES IOCTL_STORAGE_GET_MEDIA_TYPES
+ )],
+ IOCTL_DISK_ => [qw(
+ IOCTL_DISK_FORMAT_TRACKS IOCTL_DISK_FORMAT_TRACKS_EX
+ IOCTL_DISK_GET_DRIVE_GEOMETRY IOCTL_DISK_GET_DRIVE_LAYOUT
+ IOCTL_DISK_GET_MEDIA_TYPES IOCTL_DISK_GET_PARTITION_INFO
+ IOCTL_DISK_HISTOGRAM_DATA IOCTL_DISK_HISTOGRAM_RESET
+ IOCTL_DISK_HISTOGRAM_STRUCTURE IOCTL_DISK_IS_WRITABLE
+ IOCTL_DISK_LOGGING IOCTL_DISK_PERFORMANCE
+ IOCTL_DISK_REASSIGN_BLOCKS IOCTL_DISK_REQUEST_DATA
+ IOCTL_DISK_REQUEST_STRUCTURE IOCTL_DISK_SET_DRIVE_LAYOUT
+ IOCTL_DISK_SET_PARTITION_INFO IOCTL_DISK_VERIFY )],
+ GENERIC_ => [qw(
+ GENERIC_ALL GENERIC_EXECUTE
+ GENERIC_READ GENERIC_WRITE )],
+ MEDIA_TYPE => [qw(
+ Unknown F5_1Pt2_512 F3_1Pt44_512
+ F3_2Pt88_512 F3_20Pt8_512 F3_720_512
+ F5_360_512 F5_320_512 F5_320_1024
+ F5_180_512 F5_160_512 RemovableMedia
+ FixedMedia F3_120M_512 )],
+ MOVEFILE_ => [qw(
+ MOVEFILE_COPY_ALLOWED MOVEFILE_DELAY_UNTIL_REBOOT
+ MOVEFILE_REPLACE_EXISTING MOVEFILE_WRITE_THROUGH )],
+ SECURITY_ => [qw(
+ SECURITY_ANONYMOUS SECURITY_CONTEXT_TRACKING
+ SECURITY_DELEGATION SECURITY_EFFECTIVE_ONLY
+ SECURITY_IDENTIFICATION SECURITY_IMPERSONATION
+ SECURITY_SQOS_PRESENT )],
+ SEM_ => [qw(
+ SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX
+ SEM_NOALIGNMENTFAULTEXCEPT SEM_NOOPENFILEERRORBOX )],
+ PARTITION_ => [qw(
+ PARTITION_ENTRY_UNUSED PARTITION_FAT_12
+ PARTITION_XENIX_1 PARTITION_XENIX_2
+ PARTITION_FAT_16 PARTITION_EXTENDED
+ PARTITION_HUGE PARTITION_IFS
+ PARTITION_FAT32 PARTITION_FAT32_XINT13
+ PARTITION_XINT13 PARTITION_XINT13_EXTENDED
+ PARTITION_PREP PARTITION_UNIX
+ VALID_NTFT PARTITION_NTFT )],
+);
+@EXPORT_OK= ();
+{
+ my $key;
+ foreach $key ( keys(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @{$EXPORT_TAGS{$key}} );
+ #push( @EXPORT_FAIL, @{$EXPORT_TAGS{$key}} ) unless $key =~ /^Func/;
+ }
+}
+$EXPORT_TAGS{ALL}= \@EXPORT_OK;
+
+bootstrap Win32API::File $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cFile.pc
+# [instead of C or C++ code in cFile.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::File" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cFile.h"> from F<File.xs>
+# or make F<cFile.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined &GENERIC_READ ) {
+ require "Win32API/File/cFile.pc";
+}
+
+sub fileConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::fileConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= fileConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+# BEGIN {
+# my $code= 'return _fileLastError(@_)';
+# local( $!, $^E )= ( 1, 1 );
+# if( $! ne $^E ) {
+# $code= '
+# local( $^E )= _fileLastError(@_);
+# my $ret= $^E;
+# return $ret;
+# ';
+# }
+# eval "sub fileLastError { $code }";
+# die "$@" if $@;
+# }
+
+package Win32API::File::_error;
+
+use overload
+ '""' => sub {
+ require Win32 unless defined &Win32::FormatMessage;
+ $_ = Win32::FormatMessage(Win32API::File::_fileLastError());
+ tr/\r\n//d;
+ return $_;
+ },
+ '0+' => sub { Win32API::File::_fileLastError() },
+ 'fallback' => 1;
+
+sub new { return bless {}, shift }
+sub set { Win32API::File::_fileLastError($_[1]); return $_[0] }
+
+package Win32API::File;
+
+my $_error = Win32API::File::_error->new();
+
+sub fileLastError {
+ croak 'Usage: ',__PACKAGE__,'::fileLastError( [$setWin32ErrCode] )' if @_ > 1;
+ $_error->set($_[0]) if defined $_[0];
+ return $_error;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::File->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::File" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Aliases for non-Unicode functions:
+sub CopyFile { &CopyFileA; }
+sub CreateFile { &CreateFileA; }
+sub DefineDosDevice { &DefineDosDeviceA; }
+sub DeleteFile { &DeleteFileA; }
+sub GetDriveType { &GetDriveTypeA; }
+sub GetFileAttributes { &GetFileAttributesA; }
+sub GetLogicalDriveStrings { &GetLogicalDriveStringsA; }
+sub GetVolumeInformation { &GetVolumeInformationA; }
+sub MoveFile { &MoveFileA; }
+sub MoveFileEx { &MoveFileExA; }
+sub QueryDosDevice { &QueryDosDeviceA; }
+
+sub OsFHandleOpen {
+ if( 3 != @_ ) {
+ croak 'Win32API::File Usage: ',
+ 'OsFHandleOpen(FILE,$hNativeHandle,"rwatb")';
+ }
+ my( $fh, $osfh, $access )= @_;
+ if( ! ref($fh) ) {
+ if( $fh !~ /('|::)/ ) {
+ $fh= caller() . "::" . $fh;
+ }
+ no strict "refs";
+ $fh= \*{$fh};
+ }
+ my( $mode, $pref );
+ if( $access =~ /r/i ) {
+ if( $access =~ /w/i ) {
+ $mode= O_RDWR;
+ $pref= "+<";
+ } else {
+ $mode= O_RDONLY;
+ $pref= "<";
+ }
+ } else {
+ if( $access =~ /w/i ) {
+ $mode= O_WRONLY;
+ $pref= ">";
+ } else {
+ # croak qq<Win32API::File::OsFHandleOpen(): >,
+ # qq<Access ($access) missing both "r" and "w">;
+ $mode= O_RDONLY;
+ $pref= "<";
+ }
+ }
+ $mode |= O_APPEND if $access =~ /a/i;
+ #$mode |= O_TEXT if $access =~ /t/i;
+ # Some versions of the Fcntl module are broken and won't autoload O_TEXT:
+ if( $access =~ /t/i ) {
+ my $o_text= eval "O_TEXT";
+ $o_text= 0x4000 if $@;
+ $mode |= $o_text;
+ }
+ $mode |= O_BINARY if $access =~ /b/i;
+ my $fd = eval { OsFHandleOpenFd( $osfh, $mode ) };
+ if ($@) {
+ return tie *{$fh}, __PACKAGE__, $osfh;
+ }
+ return undef if $fd < 0;
+ return open( $fh, $pref."&=".$fd );
+}
+
+sub GetOsFHandle {
+ if( 1 != @_ ) {
+ croak 'Win32API::File Usage: $OsFHandle= GetOsFHandle(FILE)';
+ }
+ my( $file )= @_;
+ if( ! ref($file) ) {
+ if( $file !~ /('|::)/ ) {
+ $file= caller() . "::" . $file;
+ }
+ no strict "refs";
+ # The eval "" is necessary in Perl 5.6, avoid it otherwise.
+ my $tied = !defined($^]) || $^] < 5.008
+ ? eval "tied *{$file}"
+ : tied *{$file};
+
+ if (UNIVERSAL::isa($tied => __PACKAGE__)) {
+ return $tied->win32_handle;
+ }
+
+ $file= *{$file};
+ }
+ my( $fd )= fileno($file);
+ if( ! defined( $fd ) ) {
+ if( $file =~ /^\d+\Z/ ) {
+ $fd= $file;
+ } else {
+ return (); # $! should be set by fileno().
+ }
+ }
+ my $h= FdGetOsFHandle( $fd );
+ if( INVALID_HANDLE_VALUE() == $h ) {
+ $h= "";
+ } elsif( "0" eq $h ) {
+ $h= "0 but true";
+ }
+ return $h;
+}
+
+sub getFileSize {
+ croak 'Win32API::File Usage: $size= getFileSize($hNativeHandle)'
+ if @_ != 1;
+
+ my $handle = shift;
+ my $high_size = 0;
+
+ my $low_size = GetFileSize($handle, $high_size);
+
+ my $retval = $_64BITINT ? $high_size : Math::BigInt->new($high_size);
+
+ $retval <<= $THIRTY_TWO;
+ $retval += $low_size;
+
+ return $retval;
+}
+
+sub setFilePointer {
+ croak 'Win32API::File Usage: $pos= setFilePointer($hNativeHandle, $posl, $from_where)'
+ if @_ != 3;
+
+ my ($handle, $pos, $from_where) = @_;
+
+ my ($pos_low, $pos_high) = ($pos, 0);
+
+ if ($_64BITINT) {
+ $pos_low = ($pos & $FFFFFFFF);
+ $pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF);
+ }
+ elsif (UNIVERSAL::isa($pos => 'Math::BigInt')) {
+ $pos_low = ($pos & $FFFFFFFF)->numify();
+ $pos_high = (($pos >> $THIRTY_TWO) & $FFFFFFFF)->numify();
+ }
+
+ my $retval = SetFilePointer($handle, $pos_low, $pos_high, $from_where);
+
+ if (defined $pos_high && $pos_high != 0) {
+ if (! $_64BITINT) {
+ $retval = Math::BigInt->new($retval);
+ $pos_high = Math::BigInt->new($pos_high);
+ }
+
+ $retval += $pos_high << $THIRTY_TWO;
+ }
+
+ return $retval;
+}
+
+sub attrLetsToBits
+{
+ my( $lets )= @_;
+ my( %a )= (
+ "a"=>FILE_ATTRIBUTE_ARCHIVE(), "c"=>FILE_ATTRIBUTE_COMPRESSED(),
+ "h"=>FILE_ATTRIBUTE_HIDDEN(), "o"=>FILE_ATTRIBUTE_OFFLINE(),
+ "r"=>FILE_ATTRIBUTE_READONLY(), "s"=>FILE_ATTRIBUTE_SYSTEM(),
+ "t"=>FILE_ATTRIBUTE_TEMPORARY() );
+ my( $bits )= 0;
+ foreach( split(//,$lets) ) {
+ croak "Win32API::File::attrLetsToBits: Unknown attribute letter ($_)"
+ unless exists $a{$_};
+ $bits |= $a{$_};
+ }
+ return $bits;
+}
+
+use vars qw( @_createFile_Opts %_createFile_Opts );
+@_createFile_Opts= qw( Access Create Share Attributes
+ Flags Security Model );
+@_createFile_Opts{@_createFile_Opts}= (1) x @_createFile_Opts;
+
+sub createFile
+{
+ my $opts= "";
+ if( 2 <= @_ && "HASH" eq ref($_[$#_]) ) {
+ $opts= pop( @_ );
+ }
+ my( $sPath, $svAccess, $svShare )= @_;
+ if( @_ < 1 || 3 < @_ ) {
+ croak "Win32API::File::createFile() usage: \$hObject= createFile(\n",
+ " \$sPath, [\$svAccess_qrw_ktn_ce,[\$svShare_rwd,]]",
+ " [{Option=>\$Value}] )\n",
+ " options: @_createFile_Opts\nCalled";
+ }
+ my( $create, $flags, $sec, $model )= ( "", 0, [], 0 );
+ if( ref($opts) ) {
+ my @err= grep( ! $_createFile_Opts{$_}, keys(%$opts) );
+ @err and croak "_createFile: Invalid options (@err)";
+ $flags= $opts->{Flags} if exists( $opts->{Flags} );
+ $flags |= attrLetsToBits( $opts->{Attributes} )
+ if exists( $opts->{Attributes} );
+ $sec= $opts->{Security} if exists( $opts->{Security} );
+ $model= $opts->{Model} if exists( $opts->{Model} );
+ $svAccess= $opts->{Access} if exists( $opts->{Access} );
+ $create= $opts->{Create} if exists( $opts->{Create} );
+ $svShare= $opts->{Share} if exists( $opts->{Share} );
+ }
+ $svAccess= "r" unless defined($svAccess);
+ $svShare= "rw" unless defined($svShare);
+ if( $svAccess =~ /^[qrw ktn ce]*$/i ) {
+ ( my $c= $svAccess ) =~ tr/qrw QRW//d;
+ $create= $c if "" ne $c && "" eq $create;
+ local( $_ )= $svAccess;
+ $svAccess= 0;
+ $svAccess |= GENERIC_READ() if /r/i;
+ $svAccess |= GENERIC_WRITE() if /w/i;
+ } elsif( "?" eq $svAccess ) {
+ croak
+ "Win32API::File::createFile: \$svAccess can use the following:\n",
+ " One or more of the following:\n",
+ "\tq -- Query access (same as 0)\n",
+ "\tr -- Read access (GENERIC_READ)\n",
+ "\tw -- Write access (GENERIC_WRITE)\n",
+ " At most one of the following:\n",
+ "\tk -- Keep if exists\n",
+ "\tt -- Truncate if exists\n",
+ "\tn -- New file only (fail if file already exists)\n",
+ " At most one of the following:\n",
+ "\tc -- Create if doesn't exist\n",
+ "\te -- Existing file only (fail if doesn't exist)\n",
+ " '' is the same as 'q k e'\n",
+ " 'r' is the same as 'r k e'\n",
+ " 'w' is the same as 'w t c'\n",
+ " 'rw' is the same as 'rw k c'\n",
+ " 'rt' or 'rn' implies 'c'.\n",
+ " Or \$svAccess can be numeric.\n", "Called from";
+ } elsif( $svAccess == 0 && $svAccess !~ /^[-+.]*0/ ) {
+ croak "Win32API::File::createFile: Invalid \$svAccess ($svAccess)";
+ }
+ if( $create =~ /^[ktn ce]*$/ ) {
+ local( $_ )= $create;
+ my( $k, $t, $n, $c, $e )= ( scalar(/k/i), scalar(/t/i),
+ scalar(/n/i), scalar(/c/i), scalar(/e/i) );
+ if( 1 < $k + $t + $n ) {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<more than one of "k", "t", and "n" ($create)>;
+ }
+ if( $c && $e ) {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<both "c" and "e" ($create)>;
+ }
+ my $r= ( $svAccess & GENERIC_READ() ) == GENERIC_READ();
+ my $w= ( $svAccess & GENERIC_WRITE() ) == GENERIC_WRITE();
+ if( ! $k && ! $t && ! $n ) {
+ if( $w && ! $r ) { $t= 1;
+ } else { $k= 1; }
+ }
+ if( $k ) {
+ if( $c || $w && ! $e ) { $create= OPEN_ALWAYS();
+ } else { $create= OPEN_EXISTING(); }
+ } elsif( $t ) {
+ if( $e ) { $create= TRUNCATE_EXISTING();
+ } else { $create= CREATE_ALWAYS(); }
+ } else { # $n
+ if( ! $e ) { $create= CREATE_NEW();
+ } else {
+ croak "Win32API::File::createFile: \$create must not use ",
+ qq<both "n" and "e" ($create)>;
+ }
+ }
+ } elsif( "?" eq $create ) {
+ croak 'Win32API::File::createFile: $create !~ /^[ktn ce]*$/;',
+ ' pass $svAccess as "?" for more information.';
+ } elsif( $create == 0 && $create ne "0" ) {
+ croak "Win32API::File::createFile: Invalid \$create ($create)";
+ }
+ if( $svShare =~ /^[drw]*$/ ) {
+ my %s= ( "d"=>FILE_SHARE_DELETE(), "r"=>FILE_SHARE_READ(),
+ "w"=>FILE_SHARE_WRITE() );
+ my @s= split(//,$svShare);
+ $svShare= 0;
+ foreach( @s ) {
+ $svShare |= $s{$_};
+ }
+ } elsif( $svShare == 0 && $svShare !~ /^[-+.]*0/ ) {
+ croak "Win32API::File::createFile: Invalid \$svShare ($svShare)";
+ }
+ return CreateFileA(
+ $sPath, $svAccess, $svShare, $sec, $create, $flags, $model );
+}
+
+
+sub getLogicalDrives
+{
+ my( $ref )= @_;
+ my $s= "";
+ if( ! GetLogicalDriveStringsA( 256, $s ) ) {
+ return undef;
+ }
+ if( ! defined($ref) ) {
+ return split( /\0/, $s );
+ } elsif( "ARRAY" ne ref($ref) ) {
+ croak 'Usage: C<@arr= getLogicalDrives()> ',
+ 'or C<getLogicalDrives(\\@arr)>', "\n";
+ }
+ @$ref= split( /\0/, $s );
+ return $ref;
+}
+
+###############################################################################
+# Experimental Tied Handle and Object Oriented interface. #
+###############################################################################
+
+sub new {
+ my $class = shift;
+ $class = ref $class || $class;
+
+ my $self = IO::File::new($class);
+ tie *$self, __PACKAGE__;
+
+ $self->open(@_) if @_;
+
+ return $self;
+}
+
+sub TIEHANDLE {
+ my ($class, $win32_handle) = @_;
+ $class = ref $class || $class;
+
+ return bless {
+ _win32_handle => $win32_handle,
+ _binmode => 0,
+ _buffered => 0,
+ _buffer => '',
+ _eof => 0,
+ _fileno => undef,
+ _access => 'r',
+ _append => 0,
+ }, $class;
+}
+
+# This is called for getting the tied object from hard refs to glob refs in
+# some cases, for reasons I don't quite grok.
+
+sub FETCH { return $_[0] }
+
+# Public accessors
+
+sub win32_handle{ $_[0]->{_win32_handle}||= $_[1] }
+
+# Protected accessors
+
+sub _buffer { $_[0]->{_buffer} ||= $_[1] }
+sub _binmode { $_[0]->{_binmode} ||= $_[1] }
+sub _fileno { $_[0]->{_fileno} ||= $_[1] }
+sub _access { $_[0]->{_access} ||= $_[1] }
+sub _append { $_[0]->{_append} ||= $_[1] }
+
+# Tie interface
+
+sub OPEN {
+ my $self = shift;
+ my $expr = shift;
+ croak "Only the two argument form of open is supported at this time" if @_;
+# FIXME: this needs to parse the full Perl open syntax in $expr
+
+ my ($mixed, $mode, $path) =
+ ($expr =~ /^\s* (\+)? \s* (<|>|>>)? \s* (.*?) \s*$/x);
+
+ croak "Unsupported open mode" if not $path;
+
+ my $access = 'r';
+ my $append = $mode eq '>>' ? 1 : 0;
+
+ if ($mixed) {
+ $access = 'rw';
+ } elsif($mode eq '>') {
+ $access = 'w';
+ }
+
+ my $w32_handle = createFile($path, $access);
+
+ $self->win32_handle($w32_handle);
+
+ $self->seek(1,2) if $append;
+
+ $self->_access($access);
+ $self->_append($append);
+
+ return 1;
+}
+
+sub BINMODE {
+ $_[0]->_binmode(1);
+}
+
+sub WRITE {
+ my ($self, $buf, $len, $offset, $overlap) = @_;
+
+ if ($offset) {
+ $buf = substr($buf, $offset);
+ $len = length($buf);
+ }
+
+ $len = length($buf) if not defined $len;
+
+ $overlap = [] if not defined $overlap;;
+
+ my $bytes_written = 0;
+
+ WriteFile (
+ $self->win32_handle, $buf, $len,
+ $bytes_written, $overlap
+ );
+
+ return $bytes_written;
+}
+
+sub PRINT {
+ my $self = shift;
+
+ my $buf = join defined $, ? $, : "" => @_;
+
+ $buf =~ s/\012/\015\012/sg unless $self->_binmode();
+
+ $buf .= $\ if defined $\;
+
+ $self->WRITE($buf, length($buf), 0);
+}
+
+sub READ {
+ my $self = shift;
+ my $into = \$_[0]; shift;
+ my ($len, $offset, $overlap) = @_;
+
+ my $buffer = defined $self->_buffer ? $self->_buffer : "";
+ my $buf_length = length($buffer);
+ my $bytes_read = 0;
+ my $data;
+ $offset = 0 if not defined $offset;
+
+ if ($buf_length >= $len) {
+ $data = substr($buffer, 0, $len => "");
+ $bytes_read = $len;
+ $self->_buffer($buffer);
+ } else {
+ if ($buf_length > 0) {
+ $len -= $buf_length;
+ substr($$into, $offset) = $buffer;
+ $offset += $buf_length;
+ }
+
+ $overlap ||= [];
+
+ ReadFile (
+ $self->win32_handle, $data, $len,
+ $bytes_read, $overlap
+ );
+ }
+
+ $$into = "" if not defined $$into;
+
+ substr($$into, $offset) = $data;
+
+ return $bytes_read;
+}
+
+sub READLINE {
+ my $self = shift;
+ my $line = "";
+
+ while ((index $line, $/) == $[-1) { # read until end of line marker
+ my $char = $self->GETC();
+
+ last if !defined $char || $char eq '';
+
+ $line .= $char;
+ }
+
+ return undef if $line eq '';
+
+ return $line;
+}
+
+
+sub FILENO {
+ my $self = shift;
+
+ return $self->_fileno() if defined $self->_fileno();
+
+ return -1 if $^O eq 'cygwin';
+
+# FIXME: We don't always open the handle, better to query the handle or to set
+# the right access info at TIEHANDLE time.
+
+ my $access = $self->_access();
+ my $mode = $access eq 'rw' ? O_RDWR :
+ $access eq 'w' ? O_WRONLY : O_RDONLY;
+
+ $mode |= O_APPEND if $self->_append();
+
+ $mode |= O_TEXT if not $self->_binmode();
+
+ return $self->_fileno ( OsfHandleOpenFd (
+ $self->win32_handle, $mode
+ ));
+}
+
+sub SEEK {
+ my ($self, $pos, $whence) = @_;
+
+ $whence = 0 if not defined $whence;
+ my @file_consts = map {
+ fileConstant($_)
+ } qw(FILE_BEGIN FILE_CURRENT FILE_END);
+
+ my $from_where = $file_consts[$whence];
+
+ return setFilePointer($self->win32_handle, $pos, $from_where);
+}
+
+sub TELL {
+# SetFilePointer with position 0 at FILE_CURRENT will return position.
+ return $_[0]->SEEK(0, 1);
+}
+
+sub EOF {
+ my $self = shift;
+
+ my $current = $self->TELL() + 0;
+ my $end = getFileSize($self->win32_handle) + 0;
+
+ return $current == $end;
+}
+
+sub CLOSE {
+ my $self = shift;
+
+ my $retval = 1;
+
+ if (defined $self->win32_handle) {
+ $retval = CloseHandle($self->win32_handle);
+
+ $self->win32_handle(undef);
+ }
+
+ return $retval;
+}
+
+# Only close the handle on explicit close, too many problems otherwise.
+sub UNTIE {}
+
+sub DESTROY {}
+
+# End of Tie/OO Interface
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::File - Low-level access to Win32 system API calls for files/dirs.
+
+=head1 SYNOPSIS
+
+ use Win32API::File 0.08 qw( :ALL );
+
+ MoveFile( $Source, $Destination )
+ or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
+ MoveFileEx( $Source, $Destination, MOVEFILE_REPLACE_EXISTING() )
+ or die "Can't move $Source to $Destination: ",fileLastError(),"\n";
+ [...]
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with files and directories.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All functions, unless otherwise noted, return a true value for success
+and a false value for failure and set C<$^E> on failure.
+
+=head2 Object Oriented/Tied Handle Interface
+
+WARNING: this is new code, use at your own risk.
+
+This version of C<Win32API::File> can be used like an C<IO::File> object:
+
+ my $file = Win32API::File->new("+> foo");
+ binmode $file;
+ print $file "hello there\n";
+ seek $file, 0, 0;
+ my $line = <$file>;
+ $file->close;
+
+It also supports tying via a win32 handle (for example, from C<createFile()>):
+
+ tie FILE, 'Win32API::File', $win32_handle;
+ print FILE "...";
+
+It has not been extensively tested yet and buffered I/O is not yet implemented.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have large sets of symbols exported: C<":Func">, C<":FuncA">,
+C<":FuncW">, C<":Misc">, C<":DDD_">, C<":DRIVE_">, C<":FILE_">,
+C<":FILE_ATTRIBUTE_">, C<":FILE_FLAG_">, C<":FILE_SHARE_">,
+C<":FILE_TYPE_">, C<":FS_">, C<":FSCTL_">, C<":HANDLE_FLAG_">,
+C<":IOCTL_STORAGE_">, C<":IOCTL_DISK_">, C<":GENERIC_">,
+C<":MEDIA_TYPE">, C<":MOVEFILE_">, C<":SECURITY_">, C<":SEM_">,
+and C<":PARTITION_">.
+
+=over
+
+=item C<":Func">
+
+The basic function names: C<attrLetsToBits>, C<createFile>,
+C<fileConstant>, C<fileLastError>, C<getLogicalDrives>,
+C<setFilePointer>, C<getFileSize>,
+C<CloseHandle>, C<CopyFile>, C<CreateFile>,
+C<DefineDosDevice>, C<DeleteFile>, C<DeviceIoControl>,
+C<FdGetOsFHandle>, C<GetDriveType>, C<GetFileAttributes>,
+C<GetFileSize>, C<GetFileType>, C<GetHandleInformation>,
+C<GetLogicalDrives>, C<GetLogicalDriveStrings>, C<GetOsFHandle>,
+C<GetOverlappedResult>, C<GetVolumeInformation>, C<IsContainerPartition>,
+C<IsRecognizedPartition>, C<MoveFile>, C<MoveFileEx>,
+C<OsFHandleOpen>, C<OsFHandleOpenFd>, C<QueryDosDevice>,
+C<ReadFile>, C<SetErrorMode>, C<SetFilePointer>,
+C<SetHandleInformation>, and C<WriteFile>.
+
+=over
+
+=item attrLetsToBits
+
+=item C<$uBits= attrLetsToBits( $sAttributeLetters )>
+
+Converts a string of file attribute letters into an unsigned value with
+the corresponding bits set. C<$sAttributeLetters> should contain zero
+or more letters from C<"achorst">:
+
+=over
+
+=item C<"a">
+
+C<FILE_ATTRIBUTE_ARCHIVE>
+
+=item C<"c">
+
+C<FILE_ATTRIBUTE_COMPRESSED>
+
+=item C<"h">
+
+C<FILE_ATTRIBUTE_HIDDEN>
+
+=item C<"o">
+
+C<FILE_ATTRIBUTE_OFFLINE>
+
+=item C<"r">
+
+C<FILE_ATTRIBUTE_READONLY>
+
+=item C<"s">
+
+C<FILE_ATTRIBUTE_SYSTEM>
+
+=item C<"t">
+
+C<FILE_ATTRIBUTE_TEMPORARY>
+
+=back
+
+=item createFile
+
+=item C<$hObject= createFile( $sPath )>
+
+=item C<$hObject= createFile( $sPath, $rvhvOptions )>
+
+=item C<$hObject= createFile( $sPath, $svAccess )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $rvhvOptions )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $svShare )>
+
+=item C<$hObject= createFile( $sPath, $svAccess, $svShare, $rvhvOptions )>
+
+This is a Perl-friendly wrapper around C<CreateFile>.
+
+On failure, C<$hObject> gets set to a false value and C<regLastError()>
+and C<$^E> are set to the reason for the failure. Otherwise,
+C<$hObject> gets set to a Win32 native file handle which is alwasy
+a true value [returns C<"0 but true"> in the impossible(?) case of
+the handle having a value of C<0>].
+
+C<$sPath> is the path to the file [or device, etc.] to be opened. See
+C<CreateFile> for more information on possible special values for
+C<$sPath>.
+
+C<$svAccess> can be a number containing the bit mask representing
+the specific type(s) of access to the file that you desire. See the
+C<$uAccess> parameter to C<CreateFile> for more information on these
+values.
+
+More likely, C<$svAccess> is a string describing the generic type of
+access you desire and possibly the file creation options to use. In
+this case, C<$svAccess> should contain zero or more characters from
+C<"qrw"> [access desired], zero or one character each from C<"ktn">
+and C<"ce">, and optional white space. These letters stand for,
+respectively, "Query access", "Read access", "Write access", "Keep if
+exists", "Truncate if exists", "New file only", "Create if none", and
+"Existing file only". Case is ignored.
+
+You can pass in C<"?"> for C<$svAccess> to have an error message
+displayed summarizing its possible values. This is very handy when
+doing on-the-fly programming using the Perl debugger:
+
+ Win32API::File::createFile: $svAccess can use the following:
+ One or more of the following:
+ q -- Query access (same as 0)
+ r -- Read access (GENERIC_READ)
+ w -- Write access (GENERIC_WRITE)
+ At most one of the following:
+ k -- Keep if exists
+ t -- Truncate if exists
+ n -- New file only (fail if file already exists)
+ At most one of the following:
+ c -- Create if doesn't exist
+ e -- Existing file only (fail if doesn't exist)
+ '' is the same as 'q k e'
+ 'r' is the same as 'r k e'
+ 'w' is the same as 'w t c'
+ 'rw' is the same as 'rw k c'
+ 'rt' or 'rn' implies 'c'.
+ Or $access can be numeric.
+
+C<$svAccess> is designed to be "do what I mean", so you can skip
+the rest of its explanation unless you are interested in the complex
+details. Note that, if you want write access to a device, you need
+to specify C<"k"> [and perhaps C<"e">, as in C<"w ke"> or C<"rw ke">]
+since Win32 suggests C<OPEN_EXISTING> be used when opening a device.
+
+=over
+
+=item C<"q">
+
+Stands for "Query access". This is really a no-op since you always have
+query access when you open a file. You can specify C<"q"> to document
+that you plan to query the file [or device, etc.]. This is especially
+helpful when you don't want read nor write access since something like
+C<"q"> or C<"q ke"> may be easier to understand than just C<""> or C<"ke">.
+
+=item C<"r">
+
+Stands for "Read access". Sets the C<GENERIC_READ> bit(s) in the
+C<$uAccess> that is passed to C<CreateFile>. This is the default
+access if the C<$svAccess> parameter is missing [or if it is C<undef>
+and C<$rvhvOptions> doesn't specify an C<"Access"> option].
+
+=item C<"w">
+
+Stands for "Write access". Sets the C<GENERIC_WRITE> bit(s) in the
+C<$uAccess> that is passed to C<CreateFile>.
+
+=item C<"k">
+
+Stands for "Keep if exists". If the requested file exists, then it is
+opened. This is the default unless C<GENERIC_WRITE> access has been
+requested but C<GENERIC_READ> access has not been requested. Contrast
+with C<"t"> and C<"n">.
+
+=item C<"t">
+
+Stands for "Truncate if exists". If the requested file exists, then
+it is truncated to zero length and then opened. This is the default if
+C<GENERIC_WRITE> access has been requested and C<GENERIC_READ> access
+has not been requested. Contrast with C<"k"> and C<"n">.
+
+=item C<"n">
+
+Stands for "New file only". If the requested file exists, then it is
+not opened and the C<createFile> call fails. Contrast with C<"k"> and
+C<"t">. Can't be used with C<"e">.
+
+=item C<"c">
+
+Stands for "Create if none". If the requested file does not
+exist, then it is created and then opened. This is the default
+if C<GENERIC_WRITE> access has been requested or if C<"t"> or
+C<"n"> was specified. Contrast with C<"e">.
+
+=item C<"e">
+
+Stands for "Existing file only". If the requested file does not
+exist, then nothing is opened and the C<createFile> call fails. This
+is the default unless C<GENERIC_WRITE> access has been requested or
+C<"t"> or C<"n"> was specified. Contrast with C<"c">. Can't be
+used with C<"n">.
+
+=back
+
+The characters from C<"ktn"> and C<"ce"> are combined to determine the
+what value for C<$uCreate> to pass to C<CreateFile> [unless overridden
+by C<$rvhvOptions>]:
+
+=over
+
+=item C<"kc">
+
+C<OPEN_ALWAYS>
+
+=item C<"ke">
+
+C<OPEN_EXISTING>
+
+=item C<"tc">
+
+C<TRUNCATE_EXISTING>
+
+=item C<"te">
+
+C<CREATE_ALWAYS>
+
+=item C<"nc">
+
+C<CREATE_NEW>
+
+=item C<"ne">
+
+Illegal.
+
+=back
+
+C<$svShare> controls how the file is shared, that is, whether other
+processes can have read, write, and/or delete access to the file while
+we have it opened. C<$svShare> will usually be a string containing zero
+or more characters from C<"rwd"> but can also be a numeric bit mask.
+
+C<"r"> sets the C<FILE_SHARE_READ> bit which allows other processes to have
+read access to the file. C<"w"> sets the C<FILE_SHARE_WRITE> bit which
+allows other processes to have write access to the file. C<"d"> sets the
+C<FILE_SHARE_DELETE> bit which allows other processes to have delete access
+to the file [ignored under Windows 95].
+
+The default for C<$svShare> is C<"rw"> which provides the same sharing as
+using regular perl C<open()>.
+
+If another process currently has read, write, and/or delete access to
+the file and you don't allow that level of sharing, then your call to
+C<createFile> will fail. If you requested read, write, and/or delete
+access and another process already has the file open but doesn't allow
+that level of sharing, then your call to C<createFile> will fail. Once
+you have the file open, if another process tries to open it with read,
+write, and/or delete access and you don't allow that level of sharing,
+then that process won't be allowed to open the file.
+
+C<$rvhvOptions> is a reference to a hash where any keys must be from
+the list C<qw( Access Create Share Attributes Flags Security Model )>.
+The meaning of the value depends on the key name, as described below.
+Any option values in C<$rvhvOptions> override the settings from
+C<$svAccess> and C<$svShare> if they conflict.
+
+=over
+
+=item Flags => $uFlags
+
+C<$uFlags> is an unsigned value having any of the C<FILE_FLAG_*> or
+C<FILE_ATTRIBUTE_*> bits set. Any C<FILE_ATTRIBUTE_*> bits set via the
+C<Attributes> option are logically C<or>ed with these bits. Defaults
+to C<0>.
+
+If opening the client side of a named pipe, then you can also specify
+C<SECURITY_SQOS_PRESENT> along with one of the other C<SECURITY_*>
+constants to specify the security quality of service to be used.
+
+=item Attributes => $sAttributes
+
+A string of zero or more characters from C<"achorst"> [see C<attrLetsToBits>
+for more information] which are converted to C<FILE_ATTRIBUTE_*> bits to
+be set in the C<$uFlags> argument passed to C<CreateFile>.
+
+=item Security => $pSecurityAttributes
+
+C<$pSecurityAttributes> should contain a C<SECURITY_ATTRIBUTES> structure
+packed into a string or C<[]> [the default].
+
+=item Model => $hModelFile
+
+C<$hModelFile> should contain a handle opened with C<GENERIC_READ>
+access to a model file from which file attributes and extended attributes
+are to be copied. Or C<$hModelFile> can be C<0> [the default].
+
+=item Access => $sAccess
+
+=item Access => $uAccess
+
+C<$sAccess> should be a string of zero or more characters from
+C<"qrw"> specifying the type of access desired: "query" or C<0>,
+"read" or C<GENERIC_READ> [the default], or "write" or
+C<GENERIC_WRITE>.
+
+C<$uAccess> should be an unsigned value containing bits set to
+indicate the type of access desired. C<GENERIC_READ> is the default.
+
+=item Create => $sCreate
+
+=item Create => $uCreate
+
+C<$sCreate> should be a string constaing zero or one character from
+C<"ktn"> and zero or one character from C<"ce">. These stand for
+"Keep if exists", "Truncate if exists", "New file only", "Create if
+none", and "Existing file only". These are translated into a
+C<$uCreate> value.
+
+C<$uCreate> should be one of C<OPEN_ALWAYS>, C<OPEN_EXISTING>,
+C<TRUNCATE_EXISTING>, C<CREATE_ALWAYS>, or C<CREATE_NEW>.
+
+=item Share => $sShare
+
+=item Share => $uShare
+
+C<$sShare> should be a string with zero or more characters from
+C<"rwd"> that is translated into a C<$uShare> value. C<"rw"> is
+the default.
+
+C<$uShare> should be an unsigned value having zero or more of the
+following bits set: C<FILE_SHARE_READ>, C<FILE_SHARE_WRITE>, and
+C<FILE_SHARE_DELETE>. C<FILE_SHARE_READ|FILE_SHARE_WRITE> is the
+default.
+
+=back
+
+Examples:
+
+ $hFlop= createFile( "//./A:", "r", "r" )
+ or die "Can't prevent others from writing to floppy: $^E\n";
+ $hDisk= createFile( "//./C:", "rw ke", "" )
+ or die "Can't get exclusive access to C: $^E\n";
+ $hDisk= createFile( $sFilePath, "ke",
+ { Access=>FILE_READ_ATTRIBUTES } )
+ or die "Can't read attributes of $sFilePath: $^E\n";
+ $hTemp= createFile( "$ENV{Temp}/temp.$$", "wn", "",
+ { Attributes=>"hst", Flags=>FILE_FLAG_DELETE_ON_CLOSE() } )
+ or die "Can't create temporary file, temp.$$: $^E\n";
+
+=item getLogicalDrives
+
+=item C<@roots= getLogicalDrives()>
+
+Returns the paths to the root directories of all logical drives
+currently defined. This includes all types of drive lettters, such
+as floppies, CD-ROMs, hard disks, and network shares. A typical
+return value on a poorly equipped computer would be C<("A:\\","C:\\")>.
+
+=item CloseHandle
+
+=item C<CloseHandle( $hObject )>
+
+Closes a Win32 native handle, such as one opened via C<CreateFile>.
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item CopyFile
+
+=item C<CopyFile( $sOldFileName, $sNewFileName, $bFailIfExists )>
+
+C<$sOldFileName> is the path to the file to be copied.
+C<$sNewFileName> is the path to where the file should be copied.
+Note that you can B<NOT> just specify a path to a directory in
+C<$sNewFileName> to copy the file to that directory using the
+same file name.
+
+If C<$bFailIfExists> is true and C<$sNewFileName> is the path to
+a file that already exists, then C<CopyFile> will fail. If
+C<$bFailIfExists> is falsea, then the copy of the C<$sOldFileNmae>
+file will overwrite the C<$sNewFileName> file if it already exists.
+
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item CreateFile
+
+=item C<$hObject= CreateFile( $sPath, $uAccess, $uShare, $pSecAttr, $uCreate, $uFlags, $hModel )>
+
+On failure, C<$hObject> gets set to a false value and C<$^E> and
+C<fileLastError()> are set to the reason for the failure. Otherwise,
+C<$hObject> gets set to a Win32 native file handle which is always a
+true value [returns C<"0 but true"> in the impossible(?) case of the
+handle having a value of C<0>].
+
+C<$sPath> is the path to the file [or device, etc.] to be opened.
+
+C<$sPath> can use C<"/"> or C<"\\"> as path delimiters and can even
+mix the two. We will usually only use C<"/"> in our examples since
+using C<"\\"> is usually harder to read.
+
+Under Windows NT, C<$sPath> can start with C<"//?/"> to allow the use
+of paths longer than C<MAX_PATH> [for UNC paths, replace the leading
+C<"//"> with C<"//?/UNC/">, as in C<"//?/UNC/Server/Share/Dir/File.Ext">].
+
+C<$sPath> can start with C<"//./"> to indicate that the rest of the
+path is the name of a "DOS device." You can use C<QueryDosDevice>
+to list all current DOS devices and can add or delete them with
+C<DefineDosDevice>. If you get the source-code distribution of this
+module from CPAN, then it includes an example script, F<ex/ListDevs.plx>
+that will list all current DOS devices and their "native" definition.
+Again, note that this doesn't work under Win95 nor Win98.
+
+The most common such DOS devices include:
+
+=over
+
+=item C<"//./PhysicalDrive0">
+
+Your entire first hard disk. Doesn't work under Windows 95. This
+allows you to read or write raw sectors of your hard disk and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the hard disk. Writing raw sectors and certain other operations
+can seriously damage your files or the function of your computer.
+
+Locking this for exclusive access [by specifying C<0> for C<$uShare>]
+doesn't prevent access to the partitions on the disk nor their file
+systems. So other processes can still access any raw sectors within
+a partition and can use the file system on the disk as usual.
+
+=item C<"//./C:">
+
+Your F<C:> partition. Doesn't work under Windows 95. This allows
+you to read or write raw sectors of that partition and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the partition. Writing raw sectors and certain other operations
+can seriously damage your files or the function of your computer.
+
+Locking this for exclusive access doesn't prevent access to the
+physical drive that the partition is on so other processes can
+still access the raw sectors that way. Locking this for exclusive
+access B<does> prevent other processes from opening the same raw
+partition and B<does> prevent access to the file system on it. It
+even prevents the current process from accessing the file system
+on that partition.
+
+=item C<"//./A:">
+
+The raw floppy disk. Doesn't work under Windows 95. This allows
+you to read or write raw sectors of the floppy disk and to use
+C<DeviceIoControl> to perform miscellaneous queries and operations
+to the floopy disk or drive.
+
+Locking this for exclusive access prevents all access to the floppy.
+
+=item C<"//./PIPE/PipeName">
+
+A named pipe, created via C<CreateNamedPipe>.
+
+=back
+
+C<$uAccess> is an unsigned value with bits set indicating the
+type of access desired. Usually either C<0> ["query" access],
+C<GENERIC_READ>, C<GENERIC_WRITE>, C<GENERIC_READ|GENERIC_WRITE>,
+or C<GENERIC_ALL>. More specific types of access can be specified,
+such as C<FILE_APPEND_DATA> or C<FILE_READ_EA>.
+
+C<$uShare> controls how the file is shared, that is, whether other
+processes can have read, write, and/or delete access to the file while
+we have it opened. C<$uShare> is an unsigned value with zero or more
+of these bits set: C<FILE_SHARE_READ>, C<FILE_SHARE_WRITE>, and
+C<FILE_SHARE_DELETE>.
+
+If another process currently has read, write, and/or delete access to
+the file and you don't allow that level of sharing, then your call to
+C<CreateFile> will fail. If you requested read, write, and/or delete
+access and another process already has the file open but doesn't allow
+that level of sharing, thenn your call to C<createFile> will fail. Once
+you have the file open, if another process tries to open it with read,
+write, and/or delete access and you don't allow that level of sharing,
+then that process won't be allowed to open the file.
+
+C<$pSecAttr> should either be C<[]> [for C<NULL>] or a
+C<SECURITY_ATTRIBUTES> data structure packed into a string.
+For example, if C<$pSecDesc> contains a C<SECURITY_DESCRIPTOR>
+structure packed into a string, perhaps via:
+
+ RegGetKeySecurity( $key, 4, $pSecDesc, 1024 );
+
+then you can set C<$pSecAttr> via:
+
+ $pSecAttr= pack( "L P i", 12, $pSecDesc, $bInheritHandle );
+
+C<$uCreate> is one of the following values: C<OPEN_ALWAYS>,
+C<OPEN_EXISTING>, C<TRUNCATE_EXISTING>, C<CREATE_ALWAYS>, and
+C<CREATE_NEW>.
+
+C<$uFlags> is an unsigned value with zero or more bits set indicating
+attributes to associate with the file [C<FILE_ATTRIBUTE_*> values] or
+special options [C<FILE_FLAG_*> values].
+
+If opening the client side of a named pipe, then you can also set
+C<$uFlags> to include C<SECURITY_SQOS_PRESENT> along with one of the
+other C<SECURITY_*> constants to specify the security quality of
+service to be used.
+
+C<$hModel> is C<0> [or C<[]>, both of which mean C<NULL>] or a Win32
+native handle opened with C<GENERIC_READ> access to a model file from
+which file attributes and extended attributes are to be copied if a
+new file gets created.
+
+Examples:
+
+ $hFlop= CreateFile( "//./A:", GENERIC_READ(),
+ FILE_SHARE_READ(), [], OPEN_EXISTING(), 0, [] )
+ or die "Can't prevent others from writing to floppy: $^E\n";
+ $hDisk= CreateFile( $sFilePath, FILE_READ_ATTRIBUTES(),
+ FILE_SHARE_READ()|FILE_SHARE_WRITE(), [], OPEN_EXISTING(), 0, [] )
+ or die "Can't read attributes of $sFilePath: $^E\n";
+ $hTemp= CreateFile( "$ENV{Temp}/temp.$$", GENERIC_WRITE(), 0,
+ CREATE_NEW(), FILE_FLAG_DELETE_ON_CLOSE()|attrLetsToBits("hst"), [] )
+ or die "Can't create temporary file, temp.$$: $^E\n";
+
+=item DefineDosDevice
+
+=item C<DefineDosDevice( $uFlags, $sDosDeviceName, $sTargetPath )>
+
+Defines a new DOS device, overrides the current definition of a DOS
+device, or deletes a definition of a DOS device. Like most routines,
+returns a true value if successful and a false value [and sets C<$^E>
+and C<regLastError()>] on failure.
+
+C<$sDosDeviceName> is the name of a DOS device for which we'd like
+to add or delete a definition.
+
+C<$uFlags> is an unsigned value with zero or more of the following
+bits set:
+
+=over
+
+=item C<DDD_RAW_TARGET_PATH>
+
+Indicates that C<$sTargetPath> will be a raw Windows NT object name.
+This usually means that C<$sTargetPath> starts with C<"\\Device\\">.
+Note that you cannot use C<"/"> in place of C<"\\"> in raw target path
+names.
+
+=item C<DDD_REMOVE_DEFINITION>
+
+Requests that a definition be deleted. If C<$sTargetPath> is
+C<[]> [for C<NULL>], then the most recently added definition for
+C<$sDosDeviceName> is removed. Otherwise the most recently added
+definition matching C<$sTargetPath> is removed.
+
+If the last definition is removed, then the DOS device name is
+also deleted.
+
+=item C<DDD_EXACT_MATCH_ON_REMOVE>
+
+When deleting a definition, this bit causes each C<$sTargetPath> to
+be compared to the full-length definition when searching for the most
+recently added match. If this bit is not set, then C<$sTargetPath>
+only needs to match a prefix of the definition.
+
+=back
+
+C<$sTargetPath> is the DOS device's specific definition that you
+wish to add or delete. For C<DDD_RAW_TARGET_PATH>, these usually
+start with C<"\\Device\\">. If the C<DDD_RAW_TARGET_PATH> bit is
+not set, then C<$sTargetPath> is just an ordinary path to some file
+or directory, providing the functionality of the B<subst> command.
+
+=item DeleteFile
+
+=item C<DeleteFile( $sFileName )>
+
+Deletes the named file. Compared to Perl's C<unlink>, C<DeleteFile>
+has the advantage of not deleting read-only files. For B<some>
+versions of Perl, C<unlink> silently calls C<chmod> whether it needs
+to or not before deleting the file so that files that you have
+protected by marking them as read-only are not always protected from
+Perl's C<unlink>.
+
+Like most routines, returns a true value if successful and a false
+value [and sets C<$^E> and C<regLastError()>] on failure.
+
+=item DeviceIoControl
+
+=item C<DeviceIoControl( $hDevice, $uIoControlCode, $pInBuf, $lInBuf, $opOutBuf, $lOutBuf, $olRetBytes, $pOverlapped )>
+
+Requests a special operation on an I/O [input/output] device, such
+as ejecting a tape or formatting a disk. Like most routines, returns
+a true value if successful and a false value [and sets C<$^E> and
+C<regLastError()>] on failure.
+
+C<$hDevice> is a Win32 native file handle to a device [return value
+from C<CreateFile>].
+
+C<$uIoControlCode> is an unsigned value [a C<IOCTL_*> or C<FSCTL_*>
+constant] indicating the type query or other operation to be performed.
+
+C<$pInBuf> is C<[]> [for C<NULL>] or a data structure packed into a
+string. The type of data structure depends on the C<$uIoControlCode>
+value. C<$lInBuf> is C<0> or the length of the structure in
+C<$pInBuf>. If C<$pInBuf> is not C<[]> and C<$lInBuf> is C<0>, then
+C<$lInBuf> will automatically be set to C<length($pInBuf)> for you.
+
+C<$opOutBuf> is C<[]> [for C<NULL>] or will be set to contain a
+returned data structure packed into a string. C<$lOutBuf> indicates
+how much space to allocate in C<$opOutBuf> for C<DeviceIoControl> to
+store the data structure. If C<$lOutBuf> is a number and C<$opOutBuf>
+already has a buffer allocated for it that is larger than C<$lOutBuf>
+bytes, then this larger buffer size will be passed to C<DeviceIoControl>.
+However, you can force a specific buffer size to be passed to
+C<DeviceIoControl> by prepending a C<"="> to the front of C<$lOutBuf>.
+
+C<$olRetBytes> is C<[]> or is a scalar to receive the number of bytes
+written to C<$opOutBuf>. Even when C<$olRetBytes> is C<[]>, a valid
+pointer to a C<DWORD> [and not C<NULL>] is passed to C<DeviceIoControl>.
+In this case, C<[]> just means that you don't care about the value
+that might be written to C<$olRetBytes>, which is usually the case
+since you can usually use C<length($opOutBuf)> instead.
+
+C<$pOverlapped> is C<[]> or is a C<OVERLAPPED> structure packed into
+a string. This is only useful if C<$hDevice> was opened with the
+C<FILE_FLAG_OVERLAPPED> flag set.
+
+=item FdGetOsFHandle
+
+=item C<$hNativeHandle= FdGetOsFHandle( $ivFd )>
+
+C<FdGetOsFHandle> simply calls C<_get_osfhandle()>. It was renamed
+to better fit in with the rest the function names of this module,
+in particular to distinguish it from C<GetOsFHandle>. It takes an
+integer file descriptor [as from Perl's C<fileno>] and returns the
+Win32 native file handle associated with that file descriptor or
+C<INVALID_HANDLE_VALUE> if C<$ivFd> is not an open file descriptor.
+
+When you call Perl's C<open> to set a Perl file handle [like C<STDOUT>],
+Perl calls C's C<fopen> to set a stdio C<FILE *>. C's C<fopen> calls
+something like Unix's C<open>, that is, Win32's C<_sopen>, to get an
+integer file descriptor [where 0 is for C<STDIN>, 1 for C<STDOUT>, etc.].
+Win32's C<_sopen> calls C<CreateFile> to set a C<HANDLE>, a Win32 native
+file handle. So every Perl file handle [like C<STDOUT>] has an integer
+file descriptor associated with it that you can get via C<fileno>. And,
+under Win32, every file descriptor has a Win32 native file handle
+associated with it. C<FdGetOsFHandle> lets you get access to that.
+
+C<$hNativeHandle> is set to C<INVALID_HANDLE_VALUE> [and
+C<lastFileError()> and C<$^E> are set] if C<FdGetOsFHandle> fails.
+See also C<GetOsFHandle> which provides a friendlier interface.
+
+=item fileConstant
+
+=item C<$value= fileConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::File> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item fileLastError
+
+=item C<$svError= fileLastError();>
+
+=item C<fileLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<fileLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= fileLastError()> causes C<$x>
+to give different values in string vs. numeric contexts].
+
+The last form sets the error returned by future calls to
+C<fileLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item GetDriveType
+
+=item C<$uDriveType= GetDriveType( $sRootPath )>
+
+Takes a string giving the path to the root directory of a file system
+[called a "drive" because every file system is assigned a "drive letter"]
+and returns an unsigned value indicating the type of drive the file
+system is on. The return value should be one of:
+
+=over
+
+=item C<DRIVE_UNKNOWN>
+
+None of the following.
+
+=item C<DRIVE_NO_ROOT_DIR>
+
+A "drive" that does not have a file system. This can be a drive letter
+that hasn't been defined or a drive letter assigned to a partition
+that hasn't been formatted yet.
+
+=item C<DRIVE_REMOVABLE>
+
+A floppy diskette drive or other removable media drive, but not a CD-ROM
+drive.
+
+=item C<DRIVE_FIXED>
+
+An ordinary hard disk partition.
+
+=item C<DRIVE_REMOTE>
+
+A network share.
+
+=item C<DRIVE_CDROM>
+
+A CD-ROM drive.
+
+=item C<DRIVE_RAMDISK>
+
+A "ram disk" or memory-resident virtual file system used for high-speed
+access to small amounts of temporary file space.
+
+=back
+
+=item GetFileAttributes
+
+=item C<$uAttrs = GetFileAttributes( $sPath )>
+
+Takes a path string and returns an unsigned value with attribute flags.
+If it fails, it returns INVALID_FILE_ATTRIBUTES, otherwise it can be
+one or more of the following values:
+
+=over
+
+=item C<FILE_ATTRIBUTE_ARCHIVE>
+
+The file or directory is an archive file or directory. Applications use
+this attribute to mark files for backup or removal.
+
+=item C<FILE_ATTRIBUTE_COMPRESSED>
+
+The file or directory is compressed. For a file, this means that all of
+the data in the file is compressed. For a directory, this means that
+compression is the default for newly created files and subdirectories.
+
+=item C<FILE_ATTRIBUTE_DEVICE>
+
+Reserved; do not use.
+
+=item C<FILE_ATTRIBUTE_DIRECTORY>
+
+The handle identifies a directory.
+
+=item C<FILE_ATTRIBUTE_ENCRYPTED>
+
+The file or directory is encrypted. For a file, this means that all data
+streams in the file are encrypted. For a directory, this means that
+encryption is the default for newly created files and subdirectories.
+
+=item C<FILE_ATTRIBUTE_HIDDEN>
+
+The file or directory is hidden. It is not included in an ordinary directory
+listing.
+
+=item C<FILE_ATTRIBUTE_NORMAL>
+
+The file or directory has no other attributes set. This attribute is valid
+only if used alone.
+
+=item C<FILE_ATTRIBUTE_NOT_CONTENT_INDEXED>
+
+The file will not be indexed by the content indexing service.
+
+=item C<FILE_ATTRIBUTE_OFFLINE>
+
+The data of the file is not immediately available. This attribute indicates
+that the file data has been physically moved to offline storage. This
+attribute is used by Remote Storage, the hierarchical storage management
+software. Applications should not arbitrarily change this attribute.
+
+=item C<FILE_ATTRIBUTE_READONLY>
+
+The file or directory is read-only. Applications can read the file but cannot
+write to it or delete it. In the case of a directory, applications cannot
+delete it.
+
+=item C<FILE_ATTRIBUTE_REPARSE_POINT>
+
+The file or directory has an associated reparse point.
+
+=item C<FILE_ATTRIBUTE_SPARSE_FILE>
+
+The file is a sparse file.
+
+=item C<FILE_ATTRIBUTE_SYSTEM>
+
+The file or directory is part of, or is used exclusively by, the operating
+system.
+
+=item C<FILE_ATTRIBUTE_TEMPORARY>
+
+The file is being used for temporary storage. File systems avoid writing
+data back to mass storage if sufficient cache memory is available, because
+often the application deletes the temporary file shortly after the handle is
+closed. In that case, the system can entirely avoid writing the data.
+Otherwise, the data will be written after the handle is closed.
+
+=back
+
+=item GetFileType
+
+=item C<$uFileType= GetFileType( $hFile )>
+
+Takes a Win32 native file handle and returns a C<FILE_TYPE_*> constant
+indicating the type of the file opened on that handle:
+
+=over
+
+=item C<FILE_TYPE_UNKNOWN>
+
+None of the below. Often a special device.
+
+=item C<FILE_TYPE_DISK>
+
+An ordinary disk file.
+
+=item C<FILE_TYPE_CHAR>
+
+What Unix would call a "character special file", that is, a device that
+works on character streams such as a printer port or a console.
+
+=item C<FILE_TYPE_PIPE>
+
+Either a named or anonymous pipe.
+
+=back
+
+=item getFileSize
+
+=item C<$size= getFileSize( $hFile )>
+
+This is a Perl-friendly wrapper for the C<GetFileSize> (below) API call.
+
+It takes a Win32 native file handle and returns the size in bytes. Since the
+size can be a 64 bit value, on non 64 bit integer Perls the value returned will
+be an object of type C<Math::BigInt>.
+
+=item GetFileSize
+
+=item C<$iSizeLow= GetFileSize($win32Handle, $iSizeHigh)>
+
+Returns the size of a file pointed to by C<$win32Handle>, optionally storing
+the high order 32 bits into C<$iSizeHigh> if it is not C<[]>. If $iSizeHigh is
+C<[]>, a non-zero value indicates success. Otherwise, on failure the return
+value will be C<0xffffffff> and C<fileLastError()> will not be C<NO_ERROR>.
+
+=item GetOverlappedResult
+
+=item C<$bRetval= GetOverlappedResult( $win32Handle, $pOverlapped,
+ $numBytesTransferred, $bWait )>
+
+Used for asynchronous IO in Win32 to get the result of a pending IO operation,
+such as when a file operation returns C<ERROR_IO_PENDING>. Returns a false
+value on failure. The C<$overlapped> structure and C<$numBytesTransferred>
+will be modified with the results of the operation.
+
+As far as creating the C<$pOverlapped> structure, you are currently on your own.
+
+See L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/getoverlappedresult.asp> for more information.
+
+=item GetLogicalDrives
+
+=item C<$uDriveBits= GetLogicalDrives()>
+
+Returns an unsigned value with one bit set for each drive letter currently
+defined. If "A:" is currently a valid drive letter, then the C<1> bit
+will be set in C<$uDriveBits>. If "B:" is valid, then the C<2> bit will
+be set. If "Z:" is valid, then the C<2**26> [C<0x4000000>] bit will be
+set.
+
+=item GetLogicalDriveStrings
+
+=item C<$olOutLength= GetLogicalDriveStrings( $lBufSize, $osBuffer )>
+
+For each currently defined drive letter, a C<'\0'>-terminated string
+of the path to the root of its file system is constructed. All of
+these strings are concatenated into a single larger string and an
+extra terminating C<'\0'> is added. This larger string is returned
+in C<$osBuffer>. Note that this includes drive letters that have
+been defined but that have no file system, such as drive letters
+assigned to unformatted partitions.
+
+C<$lBufSize> is the size of the buffer to allocate to store this
+list of strings. C<26*4+1> is always sufficient and should usually
+be used.
+
+C<$osBuffer> is a scalar to be set to contain the constructed string.
+
+C<$olOutLength> is the number of bytes actually written to C<$osBuffer>
+but C<length($osBuffer)> can also be used to determine this.
+
+For example, on a poorly equipped computer,
+
+ GetLogicalDriveStrings( 4*26+1, $osBuffer );
+
+might set C<$osBuffer> to the 9-character string, C<"A:\\\0C:\\\0\0">.
+
+=item GetHandleInformation
+
+=item C<GetHandleInformation( $hObject, $ouFlags )>
+
+Retrieves the flags associated with a Win32 native file handle or object
+handle.
+
+C<$hObject> is an open Win32 native file handle or an open Win32 native
+handle to some other type of object.
+
+C<$ouFlags> will be set to an unsigned value having zero or more of
+the bits C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE>
+set. See the C<":HANDLE_FLAG_"> export class for the meanings of these
+bits.
+
+=item GetOsFHandle
+
+=item C<$hNativeHandle= GetOsFHandle( FILE )>
+
+Takes a Perl file handle [like C<STDIN>] and returns the Win32 native
+file handle associated with it. See C<FdGetOsFHandle> for more
+information about Win32 native file handles.
+
+C<$hNativeHandle> is set to a false value [and C<lastFileError()> and
+C<$^E> are set] if C<GetOsFHandle> fails. C<GetOsFHandle> returns
+C<"0 but true"> in the impossible(?) case of the handle having a value
+of C<0>.
+
+=item GetVolumeInformation
+
+=item C<GetVolumeInformation( $sRootPath, $osVolName, $lVolName, $ouSerialNum, $ouMaxNameLen, $ouFsFlags, $osFsType, $lFsType )>
+
+Gets information about a file system volume, returning a true
+value if successful. On failure, returns a false value and sets
+C<fileLastError()> and C<$^E>.
+
+C<$sRootPath> is a string specifying the path to the root of the file system,
+for example, C<"C:/">.
+
+C<$osVolName> is a scalar to be set to the string representing the
+volume name, also called the file system label. C<$lVolName> is the
+number of bytes to allocate for the C<$osVolName> buffer [see
+L<Buffer Sizes> for more information].
+
+C<$ouSerialNum> is C<[]> [for C<NULL>] or will be set to the numeric
+value of the volume's serial number.
+
+C<$ouMaxNameLen> is C<[]> [for C<NULL>] or will be set to the maximum
+length allowed for a file name or directory name within the file system.
+
+C<$osFsType> is a scalar to be set to the string representing the
+file system type, such as C<"FAT"> or C<"NTFS">. C<$lFsType> is the
+number of bytes to allocate for the C<$osFsType> buffer [see
+L<Buffer Sizes> for more information].
+
+C<$ouFsFlags> is C<[]> [for C<NULL>] or will be set to an unsigned integer
+with bits set indicating properties of the file system:
+
+=over
+
+=item C<FS_CASE_IS_PRESERVED>
+
+The file system preserves the case of file names [usually true].
+That is, it doesn't change the case of file names such as forcing
+them to upper- or lower-case.
+
+=item C<FS_CASE_SENSITIVE>
+
+The file system supports the ability to not ignore the case of file
+names [but might ignore case the way you are using it]. That is, the
+file system has the ability to force you to get the letter case of a
+file's name exactly right to be able to open it. This is true for
+"NTFS" file systems, even though case in file names is usually still
+ignored.
+
+=item C<FS_UNICODE_STORED_ON_DISK>
+
+The file system preserves Unicode in file names [true for "NTFS"].
+
+=item C<FS_PERSISTENT_ACLS>
+
+The file system supports setting Access Control Lists on files [true
+for "NTFS"].
+
+=item C<FS_FILE_COMPRESSION>
+
+The file system supports compression on a per-file basis [true for
+"NTFS"].
+
+=item C<FS_VOL_IS_COMPRESSED>
+
+The entire file system is compressed such as via "DoubleSpace".
+
+=back
+
+=item IsRecognizedPartition
+
+=item C<IsRecognizedPartition( $ivPartitionType )>
+
+Takes a partition type and returns whether that partition type is
+supported under Win32. C<$ivPartitonType> is an integer value as from
+the operating system byte of a hard disk's DOS-compatible partition
+table [that is, a partition table for x86-based Win32, not, for
+example, one used with Windows NT for Alpha processors]. For example,
+the C<PartitionType> member of the C<PARTITION_INFORMATION> structure.
+
+Common values for C<$ivPartitionType> include C<PARTITION_FAT_12==1>,
+C<PARTITION_FAT_16==4>, C<PARTITION_EXTENDED==5>, C<PARTITION_FAT32==0xB>.
+
+=item IsContainerPartition
+
+=item C<IsContainerPartition( $ivPartitionType )>
+
+Takes a partition type and returns whether that partition is a
+"container" partition that is supported under Win32, that is, whether
+it is an "extended" partition that can contain "logical" partitions.
+C<$ivPartitonType> is as for C<IsRecognizedPartition>.
+
+=item MoveFile
+
+=item C<MoveFile( $sOldName, $sNewName )>
+
+Renames a file or directory. C<$sOldName> is the name of the existing
+file or directory that is to be renamed. C<$sNewName> is the new name
+to give the file or directory. Returns a true value if the move
+succeeds. For failure, returns a false value and sets
+C<fileLastErorr()> and C<$^E> to the reason for the failure.
+
+Files can be "renamed" between file systems and the file contents and
+some attributes will be moved. Directories can only be renamed within
+one file system. If there is already a file or directory named
+C<$sNewName>, then C<MoveFile> will fail.
+
+=item MoveFileEx
+
+=item C<MoveFileEx( $sOldName, $sNewName, $uFlags )>
+
+Renames a file or directory. C<$sOldName> is the name of the existing
+file or directory that is to be renamed. C<$sNewName> is the new name
+to give the file or directory. Returns a true value if the move
+succeeds. For failure, returns a false value and sets
+C<fileLastErorr()> and C<$^E> to the reason for the failure.
+
+C<$uFlags> is an unsigned value with zero or more of the following bits set:
+
+=over
+
+=item C<MOVEFILE_REPLACE_EXISTING>
+
+If this bit is set and a file [but not a directory] named C<$sNewName>
+already exists, then it will be replaced by C<$sOldName>. If this bit
+is not set then C<MoveFileEx> will fail rather than replace an existing
+C<$sNewName>.
+
+=item C<MOVEFILE_COPY_ALLOWED>
+
+Allows files [but not directories] to be moved between file systems
+by copying the C<$sOldName> file data and some attributes to
+C<$sNewName> and then deleting C<$sOldName>. If this bit is not set
+[or if C<$sOldName> denotes a directory] and C<$sNewName> refers to a
+different file system than C<$sOldName>, then C<MoveFileEx> will fail.
+
+=item C<MOVEFILE_DELAY_UNTIL_REBOOT>
+
+Preliminary verifications are made and then an entry is added to the
+Registry to cause the rename [or delete] operation to be done the
+next time this copy of the operating system is booted [right after
+any automatic file system checks have completed]. This is not
+supported under Windows 95.
+
+When this bit is set, C<$sNewName> can be C<[]> [for C<NULL>] to
+indicate that C<$sOldName> should be deleted during the next boot
+rather than renamed.
+
+Setting both the C<MOVEFILE_COPY_ALLOWED> and
+C<MOVEFILE_DELAY_UNTIL_REBOOT> bits will cause C<MoveFileEx> to fail.
+
+=item C<MOVEFILE_WRITE_THROUGH>
+
+Ensures that C<MoveFileEx> won't return until the operation has
+finished and been flushed to disk. This is not supported under
+Windows 95. Only affects file renames to another file system,
+forcing a buffer flush at the end of the copy operation.
+
+=back
+
+=item OsFHandleOpen
+
+=item C<OsFHandleOpen( FILE, $hNativeHandle, $sMode )>
+
+Opens a Perl file handle based on an already open Win32 native
+file handle [much like C's C<fdopen()> does with a file descriptor].
+Returns a true value if the open operation succeeded. For failure,
+returns a false value and sets C<$!> [and possibly C<fileLastError()>
+and C<$^E>] to the reason for the failure.
+
+C<FILE> is a Perl file handle [in any of the supported forms, a
+bareword, a string, a typeglob, or a reference to a typeglob] that
+will be opened. If C<FILE> is already open, it will automatically
+be closed before it is reopened.
+
+C<$hNativeHandle> is an open Win32 native file handle, probably the
+return value from C<CreateFile> or C<createFile>.
+
+C<$sMode> is string of zero or more letters from C<"rwatb">. These
+are translated into a combination C<O_RDONLY> [C<"r">], C<O_WRONLY>
+[C<"w">], C<O_RDWR> [C<"rw">], C<O_APPEND> [C<"a">], C<O_TEXT>
+[C<"t">], and C<O_BINARY> [C<"b">] flags [see the L<Fcntl> module]
+that is passed to C<OsFHandleOpenFd>. Currently only C<O_APPEND>
+and C<O_TEXT> have any significance.
+
+Also, a C<"r"> and/or C<"w"> in C<$sMode> is used to decide how the
+file descriptor is converted into a Perl file handle, even though this
+doesn't appear to make a difference. One of the following is used:
+
+ open( FILE, "<&=".$ivFd ) # "r" w/o "w"
+ open( FILE, ">&=".$ivFd ) # "w" w/o "r"
+ open( FILE, "+<&=".$ivFd ) # both "r" and "w"
+
+C<OsFHandleOpen> eventually calls the Win32-specific C routine
+C<_open_osfhandle()> or Perl's "improved" version called
+C<win32_open_osfhandle()>. Prior to Perl5.005, C's
+C<_open_osfhandle()> is called which will fail if
+C<GetFileType($hNativeHandle)> would return C<FILE_TYPE_UNKNOWN>. For
+Perl5.005 and later, C<OsFHandleOpen> calls C<win32_open_osfhandle()>
+from the Perl DLL which doesn't have this restriction.
+
+=item OsFHandleOpenFd
+
+=item C<$ivFD= OsFHandleOpenFd( $hNativeHandle, $uMode )>
+
+Opens a file descriptor [C<$ivFD>] based on an already open Win32
+native file handle, C<$hNativeHandle>. This just calls the
+Win32-specific C routine C<_open_osfhandle()> or Perl's "improved"
+version called C<win32_open_osfhandle()>. Prior to Perl5.005 and in Cygwin
+Perl, C's C<_open_osfhandle()> is called which will fail if
+C<GetFileType($hNativeHandle)> would return C<FILE_TYPE_UNKNOWN>. For
+Perl5.005 and later, C<OsFHandleOpenFd> calls C<win32_open_osfhandle()> from
+the Perl DLL which doesn't have this restriction.
+
+C<$uMode> the logical combination of zero or more C<O_*> constants
+exported by the C<Fcntl> module. Currently only C<O_APPEND> and
+C<O_TEXT> have any significance.
+
+C<$ivFD> will be non-negative if the open operation was successful.
+For failure, C<-1> is returned and C<$!> [and possibly
+C<fileLastError()> and C<$^E>] is set to the reason for the failure.
+
+=item QueryDosDevice
+
+=item C<$olTargetLen= QueryDosDevice( $sDosDeviceName, $osTargetPath, $lTargetBuf )>
+
+Looks up the definition of a given "DOS" device name, yielding the
+active Windows NT native device name along with any currently dormant
+definitions.
+
+C<$sDosDeviceName> is the name of the "DOS" device whose definitions
+we want. For example, C<"C:">, C<"COM1">, or C<"PhysicalDrive0">.
+If C<$sDosDeviceName> is C<[]> [for C<NULL>], the list of all DOS
+device names is returned instead.
+
+C<$osTargetPath> will be assigned a string containing the list of
+definitions. The definitions are each C<'\0'>-terminate and are
+concatenated into the string, most recent first, with an extra C<'\0'>
+at the end of the whole string [see C<GetLogicalDriveStrings> for
+a sample of this format].
+
+C<$lTargetBuf> is the size [in bytes] of the buffer to allocate for
+C<$osTargetPath>. See L<Buffer Sizes> for more information.
+
+C<$olTargetLen> is set to the number of bytes written to
+C<$osTargetPath> but you can also use C<length($osTargetPath)>
+to determine this.
+
+For failure, C<0> is returned and C<fileLastError()> and C<$^E> are
+set to the reason for the failure.
+
+=item ReadFile
+
+=item C<ReadFile( $hFile, $opBuffer, $lBytes, $olBytesRead, $pOverlapped )>
+
+Reads bytes from a file or file-like device. Returns a true value if
+the read operation was successful. For failure, returns a false value
+and sets C<fileLastError()> and C<$^E> for the reason for the failure.
+
+C<$hFile> is a Win32 native file handle that is already open to the
+file or device to read from.
+
+C<$opBuffer> will be set to a string containing the bytes read.
+
+C<$lBytes> is the number of bytes you would like to read.
+C<$opBuffer> is automatically initialized to have a buffer large
+enough to hold that many bytes. Unlike other buffer sizes, C<$lBytes>
+does not need to have a C<"="> prepended to it to prevent a larger
+value to be passed to the underlying Win32 C<ReadFile> API. However,
+a leading C<"="> will be silently ignored, even if Perl warnings are
+enabled.
+
+If C<$olBytesRead> is not C<[]>, it will be set to the actual number
+of bytes read, though C<length($opBuffer)> can also be used to
+determine this.
+
+C<$pOverlapped> is C<[]> or is a C<OVERLAPPED> structure packed
+into a string. This is only useful if C<$hFile> was opened with
+the C<FILE_FLAG_OVERLAPPED> flag set.
+
+=item SetErrorMode
+
+=item C<$uOldMode= SetErrorMode( $uNewMode )>
+
+Sets the mode controlling system error handling B<and> returns the
+previous mode value. Both C<$uOldMode> and C<$uNewMode> will have
+zero or more of the following bits set:
+
+=over
+
+=item C<SEM_FAILCRITICALERRORS>
+
+If set, indicates that when a critical error is encountered, the call
+that triggered the error fails immediately. Normally this bit is not
+set, which means that a critical error causes a dialogue box to appear
+notifying the desktop user that some application has triggered a
+critical error. The dialogue box allows the desktop user to decide
+whether the critical error is returned to the process, is ignored, or
+the offending operation is retried.
+
+This affects the C<CreateFile> and C<GetVolumeInformation> calls.
+
+Setting this bit is useful for allowing you to check whether a floppy
+diskette is in the floppy drive.
+
+=item C<SEM_NOALIGNMENTFAULTEXCEPT>
+
+If set, this causes memory access misalignment faults to be
+automatically fixed in a manner invisible to the process. This flag
+is ignored on x86-based versions of Windows NT. This flag is not
+supported on Windows 95.
+
+=item C<SEM_NOGPFAULTERRORBOX>
+
+If set, general protection faults do not generate a dialogue box but
+can instead be handled by the process via an exception handler. This
+bit should not be set by programs that don't know how to handle such
+faults.
+
+=item C<SEM_NOOPENFILEERRORBOX>
+
+If set, then when an attempt to continue reading from or writing to
+an already open file [usually on a removable medium like a floppy
+diskette] finds the file no longer available, the call will
+immediately fail. Normally this bit is not set, which means that
+instead a dialogue box will appear notifying the desktop user that
+some application has run into this problem. The dialogue box allows
+the desktop user to decide whether the failure is returned to the
+process, is ignored, or the offending operation is retried.
+
+This affects the C<ReadFile> and C<WriteFile> calls.
+
+=back
+
+=item setFilePointer
+
+=item C<$uNewPos = setFilePointer( $hFile, $ivOffset, $uFromWhere )>
+
+This is a perl-friendly wrapper for the SetFilePointer API (below).
+C<$ivOffset> can be a 64 bit integer or C<Math::BigInt> object if your Perl
+doesn't have 64 bit integers. The return value is the new offset and will
+likewise be a 64 bit integer or a C<Math::BigInt> object.
+
+=item SetFilePointer
+
+=item C<$uNewPos = SetFilePointer( $hFile, $ivOffset, $ioivOffsetHigh, $uFromWhere )>
+
+The native Win32 version of C<seek()>. C<SetFilePointer> sets the
+position within a file where the next read or write operation will
+start from.
+
+C<$hFile> is a Win32 native file handle.
+
+C<$uFromWhere> is either C<FILE_BEGIN>, C<FILE_CURRENT>, or
+C<FILE_END>, indicating that the new file position is being specified
+relative to the beginning of the file, the current file pointer, or
+the end of the file, respectively.
+
+C<$ivOffset> is [if C<$ioivOffsetHigh> is C<[]>] the offset [in bytes]
+to the new file position from the position specified via
+C<$uFromWhere>. If C<$ioivOffsetHigh> is not C<[]>, then C<$ivOffset>
+is converted to an unsigned value to be used as the low-order 4 bytes
+of the offset.
+
+C<$ioivOffsetHigh> can be C<[]> [for C<NULL>] to indicate that you are
+only specifying a 4-byte offset and the resulting file position will
+be 0xFFFFFFFE or less [just under 4GB]. Otherwise C<$ioivOfffsetHigh>
+starts out with the high-order 4 bytes [signed] of the offset and gets
+set to the [unsigned] high-order 4 bytes of the resulting file position.
+
+The underlying C<SetFilePointer> returns C<0xFFFFFFFF> to indicate
+failure, but if C<$ioivOffsetHigh> is not C<[]>, you would also have
+to check C<$^E> to determine whether C<0xFFFFFFFF> indicates an error
+or not. C<Win32API::File::SetFilePointer> does this checking for you
+and returns a false value if and only if the underlying
+C<SetFilePointer> failed. For this reason, C<$uNewPos> is set to
+C<"0 but true"> if you set the file pointer to the beginning of the
+file [or any position with 0 for the low-order 4 bytes].
+
+So the return value will be true if the seek operation was successful.
+For failure, a false value is returned and C<fileLastError()> and
+C<$^E> are set to the reason for the failure.
+
+=item SetHandleInformation
+
+=item C<SetHandleInformation( $hObject, $uMask, $uFlags )>
+
+Sets the flags associated with a Win32 native file handle or object
+handle. Returns a true value if the operation was successful. For
+failure, returns a false value and sets C<fileLastError()> and C<$^E>
+for the reason for the failure.
+
+C<$hObject> is an open Win32 native file handle or an open Win32 native
+handle to some other type of object.
+
+C<$uMask> is an unsigned value having one or more of the bits
+C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE> set.
+Only bits set in C<$uMask> will be modified by C<SetHandleInformation>.
+
+C<$uFlags> is an unsigned value having zero or more of the bits
+C<HANDLE_FLAG_INHERIT> and C<HANDLE_FLAG_PROTECT_FROM_CLOSE> set.
+For each bit set in C<$uMask>, the cooresponding bit in the handle's
+flags is set to the value of the cooresponding bit in C<$uFlags>.
+
+If C<$uOldFlags> were the value of the handle's flags before the
+call to C<SetHandleInformation>, then the value of the handle's
+flags afterward would be:
+
+ ( $uOldFlags & ~$uMask ) | ( $uFlags & $uMask )
+
+[at least as far as the C<HANDLE_FLAG_INHERIT> and
+C<HANDLE_FLAG_PROTECT_FROM_CLOSE> bits are concerned.]
+
+See the C<":HANDLE_FLAG_"> export class for the meanings of these bits.
+
+=item WriteFile
+
+=item C<WriteFile( $hFile, $pBuffer, $lBytes, $ouBytesWritten, $pOverlapped )>
+
+Write bytes to a file or file-like device. Returns a true value if
+the operation was successful. For failure, returns a false value and
+sets C<fileLastError()> and C<$^E> for the reason for the failure.
+
+C<$hFile> is a Win32 native file handle that is already open to the
+file or device to be written to.
+
+C<$pBuffer> is a string containing the bytes to be written.
+
+C<$lBytes> is the number of bytes you would like to write. If
+C<$pBuffer> is not at least C<$lBytes> long, C<WriteFile> croaks. You
+can specify C<0> for C<$lBytes> to write C<length($pBuffer)> bytes.
+A leading C<"="> on C<$lBytes> will be silently ignored, even if Perl
+warnings are enabled.
+
+C<$ouBytesWritten> will be set to the actual number of bytes written
+unless you specify it as C<[]>.
+
+C<$pOverlapped> is C<[]> or is an C<OVERLAPPED> structure packed
+into a string. This is only useful if C<$hFile> was opened with
+the C<FILE_FLAG_OVERLAPPED> flag set.
+
+=back
+
+=item C<":FuncA">
+
+The ASCII-specific functions. Each of these is just the same as the
+version without the trailing "A".
+
+ CopyFileA
+ CreateFileA
+ DefineDosDeviceA
+ DeleteFileA
+ GetDriveTypeA
+ GetFileAttributesA
+ GetLogicalDriveStringsA
+ GetVolumeInformationA
+ MoveFileA
+ MoveFileExA
+ QueryDosDeviceA
+
+=item C<":FuncW">
+
+The wide-character-specific (Unicode) functions. Each of these is
+just the same as the version without the trailing "W" except that
+strings are expected in Unicode and some lengths are measured as
+number of C<WCHAR>s instead of number of bytes, as indicated below.
+
+=over
+
+=item CopyFileW
+
+=item C<CopyFileW( $swOldFileName, $swNewFileName, $bFailIfExists )>
+
+C<$swOldFileName> and C<$swNewFileName> are Unicode strings.
+
+=item CreateFileW
+
+=item C<$hObject= CreateFileW( $swPath, $uAccess, $uShare, $pSecAttr, $uCreate, $uFlags, $hModel )>
+
+C<$swPath> is Unicode.
+
+=item DefineDosDeviceW
+
+=item C<DefineDosDeviceW( $uFlags, $swDosDeviceName, $swTargetPath )>
+
+C<$swDosDeviceName> and C<$swTargetPath> are Unicode.
+
+=item DeleteFileW
+
+=item C<DeleteFileW( $swFileName )>
+
+C<$swFileName> is Unicode.
+
+=item GetDriveTypeW
+
+=item C<$uDriveType= GetDriveTypeW( $swRootPath )>
+
+C<$swRootPath> is Unicode.
+
+=item GetFileAttributesW
+
+=item C<$uAttrs= GetFileAttributesW( $swPath )>
+
+C<$swPath> is Unicode.
+
+=item GetLogicalDriveStringsW
+
+=item C<$olwOutLength= GetLogicalDriveStringsW( $lwBufSize, $oswBuffer )>
+
+Unicode is stored in C<$oswBuffer>. C<$lwBufSize> and C<$olwOutLength>
+are measured as number of C<WCHAR>s.
+
+=item GetVolumeInformationW
+
+=item C<GetVolumeInformationW( $swRootPath, $oswVolName, $lwVolName, $ouSerialNum, $ouMaxNameLen, $ouFsFlags, $oswFsType, $lwFsType )>
+
+C<$swRootPath> is Unicode and Unicode is written to C<$oswVolName> and
+C<$oswFsType>. C<$lwVolName> and C<$lwFsType> are measures as number
+of C<WCHAR>s.
+
+=item MoveFileW
+
+=item C<MoveFileW( $swOldName, $swNewName )>
+
+C<$swOldName> and C<$swNewName> are Unicode.
+
+=item MoveFileExW
+
+=item C<MoveFileExW( $swOldName, $swNewName, $uFlags )>
+
+C<$swOldName> and C<$swNewName> are Unicode.
+
+=item QueryDosDeviceW
+
+=item C<$olwTargetLen= QueryDosDeviceW( $swDeviceName, $oswTargetPath, $lwTargetBuf )>
+
+C<$swDeviceName> is Unicode and Unicode is written to
+C<$oswTargetPath>. C<$lwTargetBuf> and C<$olwTargetLen> are measured
+as number of C<WCHAR>s.
+
+=back
+
+=item C<":Misc">
+
+Miscellaneous constants. Used for the C<$uCreate> argument of
+C<CreateFile> or the C<$uFromWhere> argument of C<SetFilePointer>.
+Plus C<INVALID_HANDLE_VALUE>, which you usually won't need to check
+for since most routines translate it into a false value.
+
+ CREATE_ALWAYS CREATE_NEW OPEN_ALWAYS
+ OPEN_EXISTING TRUNCATE_EXISTING INVALID_HANDLE_VALUE
+ FILE_BEGIN FILE_CURRENT FILE_END
+
+=item C<":DDD_">
+
+Constants for the C<$uFlags> argument of C<DefineDosDevice>.
+
+ DDD_EXACT_MATCH_ON_REMOVE
+ DDD_RAW_TARGET_PATH
+ DDD_REMOVE_DEFINITION
+
+=item C<":DRIVE_">
+
+Constants returned by C<GetDriveType>.
+
+ DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE
+ DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM
+ DRIVE_RAMDISK
+
+=item C<":FILE_">
+
+Specific types of access to files that can be requested via the
+C<$uAccess> argument to C<CreateFile>.
+
+ FILE_READ_DATA FILE_LIST_DIRECTORY
+ FILE_WRITE_DATA FILE_ADD_FILE
+ FILE_APPEND_DATA FILE_ADD_SUBDIRECTORY
+ FILE_CREATE_PIPE_INSTANCE FILE_READ_EA
+ FILE_WRITE_EA FILE_EXECUTE
+ FILE_TRAVERSE FILE_DELETE_CHILD
+ FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES
+ FILE_ALL_ACCESS FILE_GENERIC_READ
+ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE )],
+
+=item C<":FILE_ATTRIBUTE_">
+
+File attribute constants. Returned by C<attrLetsToBits> and used in
+the C<$uFlags> argument to C<CreateFile>.
+
+ FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED
+ FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL
+ FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY
+ FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY
+
+In addition, C<GetFileAttributes> can return these constants (or
+INVALID_FILE_ATTRIBUTES in case of an error).
+
+ FILE_ATTRIBUTE_DEVICE FILE_ATTRIBUTE_DIRECTORY
+ FILE_ATTRIBUTE_ENCRYPTED FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
+ FILE_ATTRIBUTE_REPARSE_POINT FILE_ATTRIBUTE_SPARSE_FILE
+
+=item C<":FILE_FLAG_">
+
+File option flag constants. Used in the C<$uFlags> argument to
+C<CreateFile>.
+
+ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_DELETE_ON_CLOSE
+ FILE_FLAG_NO_BUFFERING FILE_FLAG_OVERLAPPED
+ FILE_FLAG_POSIX_SEMANTICS FILE_FLAG_RANDOM_ACCESS
+ FILE_FLAG_SEQUENTIAL_SCAN FILE_FLAG_WRITE_THROUGH
+ FILE_FLAG_OPEN_REPARSE_POINT
+
+=item C<":FILE_SHARE_">
+
+File sharing constants. Used in the C<$uShare> argument to
+C<CreateFile>.
+
+ FILE_SHARE_DELETE FILE_SHARE_READ FILE_SHARE_WRITE
+
+=item C<":FILE_TYPE_">
+
+File type constants. Returned by C<GetFileType>.
+
+ FILE_TYPE_CHAR FILE_TYPE_DISK
+ FILE_TYPE_PIPE FILE_TYPE_UNKNOWN
+
+=item C<":FS_">
+
+File system characteristics constants. Placed in the C<$ouFsFlags>
+argument to C<GetVolumeInformation>.
+
+ FS_CASE_IS_PRESERVED FS_CASE_SENSITIVE
+ FS_UNICODE_STORED_ON_DISK FS_PERSISTENT_ACLS
+ FS_FILE_COMPRESSION FS_VOL_IS_COMPRESSED
+
+=item C<":HANDLE_FLAG_">
+
+Flag bits modifying the behavior of an object handle and accessed via
+C<GetHandleInformation> and C<SetHandleInformation>.
+
+=over
+
+=item HANDLE_FLAG_INHERIT
+
+If this bit is set, then children of this process who inherit handles
+[that is, processes created by calls to the Win32 C<CreateProcess> API
+with the C<bInheritHandles> parameter specified as C<TRUE>], will inherit
+this particular object handle.
+
+=item HANDLE_FLAG_PROTECT_FROM_CLOSE
+
+If this bit is set, then calls to C<CloseHandle> against this handle
+will be ignored, leaving the handle open and usable.
+
+=back
+
+=item C<":IOCTL_STORAGE_">
+
+I/O control operations for generic storage devices. Used in the
+C<$uIoControlCode> argument to C<DeviceIoControl>. Includes
+C<IOCTL_STORAGE_CHECK_VERIFY>, C<IOCTL_STORAGE_MEDIA_REMOVAL>,
+C<IOCTL_STORAGE_EJECT_MEDIA>, C<IOCTL_STORAGE_LOAD_MEDIA>,
+C<IOCTL_STORAGE_RESERVE>, C<IOCTL_STORAGE_RELEASE>,
+C<IOCTL_STORAGE_FIND_NEW_DEVICES>, and
+C<IOCTL_STORAGE_GET_MEDIA_TYPES>.
+
+=over
+
+=item C<IOCTL_STORAGE_CHECK_VERIFY>
+
+Verify that a device's media is accessible. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>. If C<DeviceIoControl> returns a true value, then
+the media is currently accessible.
+
+=item C<IOCTL_STORAGE_MEDIA_REMOVAL>
+
+Allows the device's media to be locked or unlocked. C<$opOutBuf> should
+be C<[]>. C<$pInBuf> should be a C<PREVENT_MEDIA_REMOVAL> data structure,
+which is simply an interger containing a boolean value:
+
+ $pInBuf= pack( "i", $bPreventMediaRemoval );
+
+=item C<IOCTL_STORAGE_EJECT_MEDIA>
+
+Requests that the device eject the media. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_LOAD_MEDIA>
+
+Requests that the device load the media. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_RESERVE>
+
+Requests that the device be reserved. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_RELEASE>
+
+Releases a previous device reservation. C<$pInBuf> and C<$opOutBuf>
+should both be C<[]>.
+
+=item C<IOCTL_STORAGE_FIND_NEW_DEVICES>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_STORAGE_GET_MEDIA_TYPES>
+
+Requests information about the type of media supported by the device.
+C<$pInBuf> should be C<[]>. C<$opOutBuf> will be set to contain a
+vector of C<DISK_GEOMETRY> data structures, which can be decoded via:
+
+ # Calculate the number of DISK_GEOMETRY structures returned:
+ my $cStructs= length($opOutBuf)/(4+4+4+4+4+4);
+ my @fields= unpack( "L l I L L L" x $cStructs, $opOutBuf )
+ my( @ucCylsLow, @ivcCylsHigh, @uMediaType, @uTracksPerCyl,
+ @uSectsPerTrack, @uBytesPerSect )= ();
+ while( @fields ) {
+ push( @ucCylsLow, unshift @fields );
+ push( @ivcCylsHigh, unshift @fields );
+ push( @uMediaType, unshift @fields );
+ push( @uTracksPerCyl, unshift @fields );
+ push( @uSectsPerTrack, unshift @fields );
+ push( @uBytesPerSect, unshift @fields );
+ }
+
+For the C<$i>th type of supported media, the following variables will
+contain the following data.
+
+=over
+
+=item C<$ucCylsLow[$i]>
+
+The low-order 4 bytes of the total number of cylinders.
+
+=item C<$ivcCylsHigh[$i]>
+
+The high-order 4 bytes of the total number of cylinders.
+
+=item C<$uMediaType[$i]>
+
+A code for the type of media. See the C<":MEDIA_TYPE"> export class.
+
+=item C<$uTracksPerCyl[$i]>
+
+The number of tracks in each cylinder.
+
+=item C<$uSectsPerTrack[$i]>
+
+The number of sectors in each track.
+
+=item C<$uBytesPerSect[$i]>
+
+The number of bytes in each sector.
+
+=back
+
+=back
+
+=item C<":IOCTL_DISK_">
+
+I/O control operations for disk devices. Used in the C<$uIoControlCode>
+argument to C<DeviceIoControl>. Most of these are to be used on
+physical drive devices like C<"//./PhysicalDrive0">. However,
+C<IOCTL_DISK_GET_PARTITION_INFO> and C<IOCTL_DISK_SET_PARTITION_INFO>
+should only be used on a single-partition device like C<"//./C:">. Also,
+C<IOCTL_DISK_GET_MEDIA_TYPES> is documented as having been superceded but
+is still useful when used on a floppy device like C<"//./A:">.
+
+Includes C<IOCTL_DISK_FORMAT_TRACKS>, C<IOCTL_DISK_FORMAT_TRACKS_EX>,
+C<IOCTL_DISK_GET_DRIVE_GEOMETRY>, C<IOCTL_DISK_GET_DRIVE_LAYOUT>,
+C<IOCTL_DISK_GET_MEDIA_TYPES>, C<IOCTL_DISK_GET_PARTITION_INFO>,
+C<IOCTL_DISK_HISTOGRAM_DATA>, C<IOCTL_DISK_HISTOGRAM_RESET>,
+C<IOCTL_DISK_HISTOGRAM_STRUCTURE>, C<IOCTL_DISK_IS_WRITABLE>,
+C<IOCTL_DISK_LOGGING>, C<IOCTL_DISK_PERFORMANCE>,
+C<IOCTL_DISK_REASSIGN_BLOCKS>, C<IOCTL_DISK_REQUEST_DATA>,
+C<IOCTL_DISK_REQUEST_STRUCTURE>, C<IOCTL_DISK_SET_DRIVE_LAYOUT>,
+C<IOCTL_DISK_SET_PARTITION_INFO>, and C<IOCTL_DISK_VERIFY>.
+
+=over
+
+=item C<IOCTL_DISK_GET_DRIVE_GEOMETRY>
+
+Request information about the size and geometry of the disk. C<$pInBuf>
+should be C<[]>. C<$opOutBuf> will be set to a C<DISK_GEOMETRY> data
+structure which can be decode via:
+
+ ( $ucCylsLow, $ivcCylsHigh, $uMediaType, $uTracksPerCyl,
+ $uSectsPerTrack, $uBytesPerSect )= unpack( "L l I L L L", $opOutBuf );
+
+=over
+
+=item C<$ucCylsLow>
+
+The low-order 4 bytes of the total number of cylinders.
+
+=item C<$ivcCylsHigh>
+
+The high-order 4 bytes of the total number of cylinders.
+
+=item C<$uMediaType>
+
+A code for the type of media. See the C<":MEDIA_TYPE"> export class.
+
+=item C<$uTracksPerCyl>
+
+The number of tracks in each cylinder.
+
+=item C<$uSectsPerTrack>
+
+The number of sectors in each track.
+
+=item C<$uBytesPerSect>
+
+The number of bytes in each sector.
+
+=back
+
+=item C<IOCTL_DISK_GET_PARTITION_INFO>
+
+Request information about the size and geometry of the partition.
+C<$pInBuf> should be C<[]>. C<$opOutBuf> will be set to a
+C<PARTITION_INFORMATION> data structure which can be decode via:
+
+ ( $uStartLow, $ivStartHigh, $ucHiddenSects, $uPartitionSeqNumber,
+ $uPartitionType, $bActive, $bRecognized, $bToRewrite )=
+ unpack( "L l L L C c c c", $opOutBuf );
+
+=over
+
+=item C<$uStartLow> and C<$ivStartHigh>
+
+The low-order and high-order [respectively] 4 bytes of the starting
+offset of the partition, measured in bytes.
+
+=item C<$ucHiddenSects>
+
+The number of "hidden" sectors for this partition. Actually this is
+the number of sectors found prior to this partiton, that is, the
+starting offset [as found in C<$uStartLow> and C<$ivStartHigh>]
+divided by the number of bytes per sector.
+
+=item C<$uPartitionSeqNumber>
+
+The sequence number of this partition. Partitions are numbered
+starting as C<1> [with "partition 0" meaning the entire disk].
+Sometimes this field may be C<0> and you'll have to infer the
+partition sequence number from how many partitions preceed it on
+the disk.
+
+=item C<$uPartitionType>
+
+The type of partition. See the C<":PARTITION_"> export class for a
+list of known types. See also C<IsRecognizedPartition> and
+C<IsContainerPartition>.
+
+=item C<$bActive>
+
+C<1> for the active [boot] partition, C<0> otherwise.
+
+=item C<$bRecognized>
+
+Whether this type of partition is support under Win32.
+
+=item C<$bToRewrite>
+
+Whether to update this partition information. This field is not used
+by C<IOCTL_DISK_GET_PARTITION_INFO>. For
+C<IOCTL_DISK_SET_DRIVE_LAYOUT>, you must set this field to a true
+value for any partitions you wish to have changed, added, or deleted.
+
+=back
+
+=item C<IOCTL_DISK_SET_PARTITION_INFO>
+
+Change the type of the partition. C<$opOutBuf> should be C<[]>.
+C<$pInBuf> should be a C<SET_PARTITION_INFORMATION> data structure
+which is just a single byte containing the new parition type [see
+the C<":PARTITION_"> export class for a list of known types]:
+
+ $pInBuf= pack( "C", $uPartitionType );
+
+=item C<IOCTL_DISK_GET_DRIVE_LAYOUT>
+
+Request information about the disk layout. C<$pInBuf> should be C<[]>.
+C<$opOutBuf> will be set to contain C<DRIVE_LAYOUT_INFORMATION>
+structure including several C<PARTITION_INFORMATION> structures:
+
+ my( $cPartitions, $uDiskSignature )= unpack( "L L", $opOutBuf );
+ my @fields= unpack( "x8" . ( "L l L L C c c c" x $cPartitions ),
+ $opOutBuf );
+ my( @uStartLow, @ivStartHigh, @ucHiddenSects,
+ @uPartitionSeqNumber, @uPartitionType, @bActive,
+ @bRecognized, @bToRewrite )= ();
+ for( 1..$cPartition ) {
+ push( @uStartLow, unshift @fields );
+ push( @ivStartHigh, unshift @fields );
+ push( @ucHiddenSects, unshift @fields );
+ push( @uPartitionSeqNumber, unshift @fields );
+ push( @uPartitionType, unshift @fields );
+ push( @bActive, unshift @fields );
+ push( @bRecognized, unshift @fields );
+ push( @bToRewrite, unshift @fields );
+ }
+
+=over
+
+=item C<$cPartitions>
+
+If the number of partitions on the disk.
+
+=item C<$uDiskSignature>
+
+Is the disk signature, a unique number assigned by Disk Administrator
+[F<WinDisk.exe>] and used to identify the disk. This allows drive
+letters for partitions on that disk to remain constant even if the
+SCSI Target ID of the disk gets changed.
+
+=back
+
+See C<IOCTL_DISK_GET_PARTITION_INFORMATION> for information on the
+remaining these fields.
+
+=item C<IOCTL_DISK_GET_MEDIA_TYPES>
+
+Is supposed to be superseded by C<IOCTL_STORAGE_GET_MEDIA_TYPES> but
+is still useful for determining the types of floppy diskette formats
+that can be produced by a given floppy drive. See
+F<ex/FormatFloppy.plx> for an example.
+
+=item C<IOCTL_DISK_SET_DRIVE_LAYOUT>
+
+Change the partition layout of the disk. C<$pOutBuf> should be C<[]>.
+C<$pInBuf> should be a C<DISK_LAYOUT_INFORMATION> data structure
+including several C<PARTITION_INFORMATION> data structures.
+
+ # Already set: $cPartitions, $uDiskSignature, @uStartLow, @ivStartHigh,
+ # @ucHiddenSects, @uPartitionSeqNumber, @uPartitionType, @bActive,
+ # @bRecognized, and @bToRewrite.
+ my( @fields, $prtn )= ();
+ for $prtn ( 1..$cPartition ) {
+ push( @fields, $uStartLow[$prtn-1], $ivStartHigh[$prtn-1],
+ $ucHiddenSects[$prtn-1], $uPartitionSeqNumber[$prtn-1],
+ $uPartitionType[$prtn-1], $bActive[$prtn-1],
+ $bRecognized[$prtn-1], $bToRewrite[$prtn-1] );
+ }
+ $pInBuf= pack( "L L" . ( "L l L L C c c c" x $cPartitions ),
+ $cPartitions, $uDiskSignature, @fields );
+
+To delete a partition, zero out all fields except for C<$bToRewrite>
+which should be set to C<1>. To add a partition, increment
+C<$cPartitions> and add the information for the new partition
+into the arrays, making sure that you insert C<1> into @bToRewrite.
+
+See C<IOCTL_DISK_GET_DRIVE_LAYOUT> and
+C<IOCTL_DISK_GET_PARITITON_INFORMATION> for descriptions of the
+fields.
+
+=item C<IOCTL_DISK_VERIFY>
+
+Performs a logical format of [part of] the disk. C<$opOutBuf> should
+be C<[]>. C<$pInBuf> should contain a C<VERIFY_INFORMATION> data
+structure:
+
+ $pInBuf= pack( "L l L",
+ $uStartOffsetLow, $ivStartOffsetHigh, $uLength );
+
+=over
+
+=item C<$uStartOffsetLow> and C<$ivStartOffsetHigh>
+
+The low-order and high-order [respectively] 4 bytes of the offset [in
+bytes] where the formatting should begin.
+
+=item C<$uLength>
+
+The length [in bytes] of the section to be formatted.
+
+=back
+
+=item C<IOCTL_DISK_FORMAT_TRACKS>
+
+Format a range of tracks on the disk. C<$opOutBuf> should be C<[]>.
+C<$pInBuf> should contain a C<FORMAT_PARAMETERS> data structure:
+
+ $pInBuf= pack( "L L L L L", $uMediaType,
+ $uStartCyl, $uEndCyl, $uStartHead, $uEndHead );
+
+C<$uMediaType> if the type of media to be formatted. Mostly used to
+specify the density to use when formatting a floppy diskette. See the
+C<":MEDIA_TYPE"> export class for more information.
+
+The remaining fields specify the starting and ending cylinder and
+head of the range of tracks to be formatted.
+
+=item C<IOCTL_DISK_REASSIGN_BLOCKS>
+
+Reassign a list of disk blocks to the disk's spare-block pool.
+C<$opOutBuf> should be C<[]>. C<$pInBuf> should be a
+C<REASSIGN_BLOCKS> data structure:
+
+ $pInBuf= pack( "S S L*", 0, $cBlocks, @uBlockNumbers );
+
+=item C<IOCTL_DISK_PERFORMANCE>
+
+Request information about disk performance. C<$pInBuf> should be C<[]>.
+C<$opOutBuf> will be set to contain a C<DISK_PERFORMANCE> data structure:
+
+ my( $ucBytesReadLow, $ivcBytesReadHigh,
+ $ucBytesWrittenLow, $ivcBytesWrittenHigh,
+ $uReadTimeLow, $ivReadTimeHigh,
+ $uWriteTimeLow, $ivWriteTimeHigh,
+ $ucReads, $ucWrites, $uQueueDepth )=
+ unpack( "L l L l L l L l L L L", $opOutBuf );
+
+=item C<IOCTL_DISK_IS_WRITABLE>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_DISK_LOGGING>
+
+Control disk logging. Little documentation for this IOCTL operation
+was found. It makes use of a C<DISK_LOGGING> data structure:
+
+=over
+
+=item DISK_LOGGING_START
+
+Start logging each disk request in a buffer internal to the disk device
+driver of size C<$uLogBufferSize>:
+
+ $pInBuf= pack( "C L L", 0, 0, $uLogBufferSize );
+
+=item DISK_LOGGING_STOP
+
+Stop loggin each disk request:
+
+ $pInBuf= pack( "C L L", 1, 0, 0 );
+
+=item DISK_LOGGING_DUMP
+
+Copy the interal log into the supplied buffer:
+
+ $pLogBuffer= ' ' x $uLogBufferSize
+ $pInBuf= pack( "C P L", 2, $pLogBuffer, $uLogBufferSize );
+
+ ( $uByteOffsetLow[$i], $ivByteOffsetHigh[$i],
+ $uStartTimeLow[$i], $ivStartTimeHigh[$i],
+ $uEndTimeLog[$i], $ivEndTimeHigh[$i],
+ $hVirtualAddress[$i], $ucBytes[$i],
+ $uDeviceNumber[$i], $bWasReading[$i] )=
+ unpack( "x".(8+8+8+4+4+1+1+2)." L l L l L l L L C c x2", $pLogBuffer );
+
+=item DISK_LOGGING_BINNING
+
+Keep statics grouped into bins based on request sizes.
+
+ $pInBuf= pack( "C P L", 3, $pUnknown, $uUnknownSize );
+
+=back
+
+=item C<IOCTL_DISK_FORMAT_TRACKS_EX>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_STRUCTURE>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_DATA>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_HISTOGRAM_RESET>
+
+No documentation on this IOCTL is included.
+
+=item C<IOCTL_DISK_REQUEST_STRUCTURE>
+
+No documentation on this IOCTL operation was found.
+
+=item C<IOCTL_DISK_REQUEST_DATA>
+
+No documentation on this IOCTL operation was found.
+
+=back
+
+=item C<":FSCTL_">
+
+File system control operations. Used in the C<$uIoControlCode>
+argument to C<DeviceIoControl>.
+
+Includes C<FSCTL_SET_REPARSE_POINT>, C<FSCTL_GET_REPARSE_POINT>,
+C<FSCTL_DELETE_REPARSE_POINT>.
+
+=over
+
+=item C<FSCTL_SET_REPARSE_POINT>
+
+Sets reparse point data to be associated with $hDevice.
+
+=item C<FSCTL_GET_REPARSE_POINT>
+
+Retrieves the reparse point data associated with $hDevice.
+
+=item C<FSCTL_DELETE_REPARSE_POINT>
+
+Deletes the reparse point data associated with $hDevice.
+
+=back
+
+=item C<":GENERIC_">
+
+Constants specifying generic access permissions that are not specific
+to one type of object.
+
+ GENERIC_ALL GENERIC_EXECUTE
+ GENERIC_READ GENERIC_WRITE
+
+=item C<":MEDIA_TYPE">
+
+Different classes of media that a device can support. Used in the
+C<$uMediaType> field of a C<DISK_GEOMETRY> structure.
+
+=over
+
+=item C<Unknown>
+
+Format is unknown.
+
+=item C<F5_1Pt2_512>
+
+5.25" floppy, 1.2MB [really 1,200KB] total space, 512 bytes/sector.
+
+=item C<F3_1Pt44_512>
+
+3.5" floppy, 1.44MB [really 1,440KB] total space, 512 bytes/sector.
+
+=item C<F3_2Pt88_512>
+
+3.5" floppy, 2.88MB [really 2,880KB] total space, 512 bytes/sector.
+
+=item C<F3_20Pt8_512>
+
+3.5" floppy, 20.8MB total space, 512 bytes/sector.
+
+=item C<F3_720_512>
+
+3.5" floppy, 720KB total space, 512 bytes/sector.
+
+=item C<F5_360_512>
+
+5.25" floppy, 360KB total space, 512 bytes/sector.
+
+=item C<F5_320_512>
+
+5.25" floppy, 320KB total space, 512 bytes/sector.
+
+=item C<F5_320_1024>
+
+5.25" floppy, 320KB total space, 1024 bytes/sector.
+
+=item C<F5_180_512>
+
+5.25" floppy, 180KB total space, 512 bytes/sector.
+
+=item C<F5_160_512>
+
+5.25" floppy, 160KB total space, 512 bytes/sector.
+
+=item C<RemovableMedia>
+
+Some type of removable media other than a floppy diskette.
+
+=item C<FixedMedia>
+
+A fixed hard disk.
+
+=item C<F3_120M_512>
+
+3.5" floppy, 120MB total space.
+
+=back
+
+=item C<":MOVEFILE_">
+
+Constants for use in C<$uFlags> arguments to C<MoveFileEx>.
+
+ MOVEFILE_COPY_ALLOWED MOVEFILE_DELAY_UNTIL_REBOOT
+ MOVEFILE_REPLACE_EXISTING MOVEFILE_WRITE_THROUGH
+
+=item C<":SECURITY_">
+
+Security quality of service values that can be used in the C<$uFlags>
+argument to C<CreateFile> if opening the client side of a named pipe.
+
+ SECURITY_ANONYMOUS SECURITY_CONTEXT_TRACKING
+ SECURITY_DELEGATION SECURITY_EFFECTIVE_ONLY
+ SECURITY_IDENTIFICATION SECURITY_IMPERSONATION
+ SECURITY_SQOS_PRESENT
+
+=item C<":SEM_">
+
+Constants to be used with C<SetErrorMode>.
+
+ SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX
+ SEM_NOALIGNMENTFAULTEXCEPT SEM_NOOPENFILEERRORBOX
+
+=item C<":PARTITION_">
+
+Constants describing partition types.
+
+ PARTITION_ENTRY_UNUSED PARTITION_FAT_12
+ PARTITION_XENIX_1 PARTITION_XENIX_2
+ PARTITION_FAT_16 PARTITION_EXTENDED
+ PARTITION_HUGE PARTITION_IFS
+ PARTITION_FAT32 PARTITION_FAT32_XINT13
+ PARTITION_XINT13 PARTITION_XINT13_EXTENDED
+ PARTITION_PREP PARTITION_UNIX
+ VALID_NTFT PARTITION_NTFT
+
+=item C<":ALL">
+
+All of the above.
+
+=back
+
+=head1 BUGS
+
+None known at this time.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+The pyramids.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc b/Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc
new file mode 100644
index 00000000000..da00f413aa2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc
@@ -0,0 +1,165 @@
+# Generated by cFile_pc.cxx.
+# Package Win32API::File with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[!/[a-z\d]/]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/], q[:MEDIA_TYPE]]
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# File.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# File.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub CREATE_ALWAYS () { 2 }
+sub CREATE_NEW () { 1 }
+sub DDD_EXACT_MATCH_ON_REMOVE () { 4 }
+sub DDD_RAW_TARGET_PATH () { 1 }
+sub DDD_REMOVE_DEFINITION () { 2 }
+sub DRIVE_CDROM () { 5 }
+sub DRIVE_FIXED () { 3 }
+sub DRIVE_NO_ROOT_DIR () { 1 }
+sub DRIVE_RAMDISK () { 6 }
+sub DRIVE_REMOTE () { 4 }
+sub DRIVE_REMOVABLE () { 2 }
+sub DRIVE_UNKNOWN () { 0 }
+sub F3_120M_512 () { 13 }
+sub F3_1Pt44_512 () { 2 }
+sub F3_20Pt8_512 () { 4 }
+sub F3_2Pt88_512 () { 3 }
+sub F3_720_512 () { 5 }
+sub F5_160_512 () { 10 }
+sub F5_180_512 () { 9 }
+sub F5_1Pt2_512 () { 1 }
+sub F5_320_1024 () { 8 }
+sub F5_320_512 () { 7 }
+sub F5_360_512 () { 6 }
+sub FILE_ADD_FILE () { 2 }
+sub FILE_ADD_SUBDIRECTORY () { 4 }
+sub FILE_ALL_ACCESS () { 2032127 }
+sub FILE_APPEND_DATA () { 4 }
+sub FILE_ATTRIBUTE_ARCHIVE () { 32 }
+sub FILE_ATTRIBUTE_COMPRESSED () { 2048 }
+sub FILE_ATTRIBUTE_DEVICE () { 0x00000040 }
+sub FILE_ATTRIBUTE_DIRECTORY () { 0x00000010 }
+sub FILE_ATTRIBUTE_ENCRYPTED () { 0x00004000 }
+sub FILE_ATTRIBUTE_HIDDEN () { 2 }
+sub FILE_ATTRIBUTE_NORMAL () { 128 }
+sub FILE_ATTRIBUTE_NOT_CONTENT_INDEXED () { 0x00002000 }
+sub FILE_ATTRIBUTE_OFFLINE () { 4096 }
+sub FILE_ATTRIBUTE_READONLY () { 1 }
+sub FILE_ATTRIBUTE_REPARSE_POINT () { 0x00000400 }
+sub FILE_ATTRIBUTE_SPARSE_FILE () { 0x00000200 }
+sub FILE_ATTRIBUTE_SYSTEM () { 4 }
+sub FILE_ATTRIBUTE_TEMPORARY () { 256 }
+sub FILE_BEGIN () { 0 }
+sub FILE_CREATE_PIPE_INSTANCE () { 4 }
+sub FILE_CURRENT () { 1 }
+sub FILE_DELETE_CHILD () { 64 }
+sub FILE_END () { 2 }
+sub FILE_EXECUTE () { 32 }
+sub FILE_FLAG_BACKUP_SEMANTICS () { 33554432 }
+sub FILE_FLAG_DELETE_ON_CLOSE () { 67108864 }
+sub FILE_FLAG_NO_BUFFERING () { 536870912 }
+sub FILE_FLAG_OPEN_REPARSE_POINT () { 0x200000 }
+sub FILE_FLAG_OVERLAPPED () { 1073741824 }
+sub FILE_FLAG_POSIX_SEMANTICS () { 16777216 }
+sub FILE_FLAG_RANDOM_ACCESS () { 268435456 }
+sub FILE_FLAG_SEQUENTIAL_SCAN () { 134217728 }
+sub FILE_FLAG_WRITE_THROUGH () { 0x80000000 }
+sub FILE_GENERIC_EXECUTE () { 1179808 }
+sub FILE_GENERIC_READ () { 1179785 }
+sub FILE_GENERIC_WRITE () { 1179926 }
+sub FILE_LIST_DIRECTORY () { 1 }
+sub FILE_READ_ATTRIBUTES () { 128 }
+sub FILE_READ_DATA () { 1 }
+sub FILE_READ_EA () { 8 }
+sub FILE_SHARE_DELETE () { 4 }
+sub FILE_SHARE_READ () { 1 }
+sub FILE_SHARE_WRITE () { 2 }
+sub FILE_TRAVERSE () { 32 }
+sub FILE_TYPE_CHAR () { 2 }
+sub FILE_TYPE_DISK () { 1 }
+sub FILE_TYPE_PIPE () { 3 }
+sub FILE_TYPE_UNKNOWN () { 0 }
+sub FILE_WRITE_ATTRIBUTES () { 256 }
+sub FILE_WRITE_DATA () { 2 }
+sub FILE_WRITE_EA () { 16 }
+sub FS_CASE_IS_PRESERVED () { 2 }
+sub FS_CASE_SENSITIVE () { 1 }
+sub FS_FILE_COMPRESSION () { 16 }
+sub FS_PERSISTENT_ACLS () { 8 }
+sub FS_UNICODE_STORED_ON_DISK () { 4 }
+sub FS_VOL_IS_COMPRESSED () { 32768 }
+sub FSCTL_SET_REPARSE_POINT () { (9 << 16 | 0 << 14 | 41 << 2 | 0) }
+sub FSCTL_GET_REPARSE_POINT () { (9 << 16 | 0 << 14 | 42 << 2 | 0) }
+sub FSCTL_DELETE_REPARSE_POINT () { (9 << 16 | 0 << 14 | 43 << 2 | 0) }
+sub FixedMedia () { 12 }
+sub GENERIC_ALL () { 268435456 }
+sub GENERIC_EXECUTE () { 536870912 }
+sub GENERIC_READ () { 0x80000000 }
+sub GENERIC_WRITE () { 1073741824 }
+sub HANDLE_FLAG_INHERIT () { 1 }
+sub HANDLE_FLAG_PROTECT_FROM_CLOSE () { 2 }
+sub INVALID_FILE_ATTRIBUTES () { 0xFFFFFFFF }
+sub INVALID_HANDLE_VALUE () { 0xffffffff }
+sub IOCTL_DISK_FORMAT_TRACKS () { 507928 }
+sub IOCTL_DISK_FORMAT_TRACKS_EX () { 507948 }
+sub IOCTL_DISK_GET_DRIVE_GEOMETRY () { 458752 }
+sub IOCTL_DISK_GET_DRIVE_LAYOUT () { 475148 }
+sub IOCTL_DISK_GET_MEDIA_TYPES () { 461824 }
+sub IOCTL_DISK_GET_PARTITION_INFO () { 475140 }
+sub IOCTL_DISK_HISTOGRAM_DATA () { 458804 }
+sub IOCTL_DISK_HISTOGRAM_RESET () { 458808 }
+sub IOCTL_DISK_HISTOGRAM_STRUCTURE () { 458800 }
+sub IOCTL_DISK_IS_WRITABLE () { 458788 }
+sub IOCTL_DISK_LOGGING () { 458792 }
+sub IOCTL_DISK_PERFORMANCE () { 458784 }
+sub IOCTL_DISK_REASSIGN_BLOCKS () { 507932 }
+sub IOCTL_DISK_REQUEST_DATA () { 458816 }
+sub IOCTL_DISK_REQUEST_STRUCTURE () { 458812 }
+sub IOCTL_DISK_SET_DRIVE_LAYOUT () { 507920 }
+sub IOCTL_DISK_SET_PARTITION_INFO () { 507912 }
+sub IOCTL_DISK_VERIFY () { 458772 }
+sub IOCTL_STORAGE_CHECK_VERIFY () { 2967552 }
+sub IOCTL_STORAGE_EJECT_MEDIA () { 2967560 }
+sub IOCTL_STORAGE_FIND_NEW_DEVICES () { 2967576 }
+sub IOCTL_STORAGE_GET_MEDIA_TYPES () { 2952192 }
+sub IOCTL_STORAGE_LOAD_MEDIA () { 2967564 }
+sub IOCTL_STORAGE_MEDIA_REMOVAL () { 2967556 }
+sub IOCTL_STORAGE_RELEASE () { 2967572 }
+sub IOCTL_STORAGE_RESERVE () { 2967568 }
+sub MOVEFILE_COPY_ALLOWED () { 2 }
+sub MOVEFILE_DELAY_UNTIL_REBOOT () { 4 }
+sub MOVEFILE_REPLACE_EXISTING () { 1 }
+sub MOVEFILE_WRITE_THROUGH () { 8 }
+sub OPEN_ALWAYS () { 4 }
+sub OPEN_EXISTING () { 3 }
+sub PARTITION_ENTRY_UNUSED () { 0 }
+sub PARTITION_EXTENDED () { 5 }
+sub PARTITION_FAT32 () { 11 }
+sub PARTITION_FAT32_XINT13 () { 12 }
+sub PARTITION_FAT_12 () { 1 }
+sub PARTITION_FAT_16 () { 4 }
+sub PARTITION_HUGE () { 6 }
+sub PARTITION_IFS () { 7 }
+sub PARTITION_NTFT () { 128 }
+sub PARTITION_PREP () { 65 }
+sub PARTITION_UNIX () { 99 }
+sub PARTITION_XENIX_1 () { 2 }
+sub PARTITION_XENIX_2 () { 3 }
+sub PARTITION_XINT13 () { 14 }
+sub PARTITION_XINT13_EXTENDED () { 15 }
+sub RemovableMedia () { 11 }
+sub SECURITY_ANONYMOUS () { 0 }
+sub SECURITY_CONTEXT_TRACKING () { 262144 }
+sub SECURITY_DELEGATION () { 196608 }
+sub SECURITY_EFFECTIVE_ONLY () { 524288 }
+sub SECURITY_IDENTIFICATION () { 65536 }
+sub SECURITY_IMPERSONATION () { 131072 }
+sub SECURITY_SQOS_PRESENT () { 1048576 }
+sub SEM_FAILCRITICALERRORS () { 1 }
+sub SEM_NOALIGNMENTFAULTEXCEPT () { 4 }
+sub SEM_NOGPFAULTERRORBOX () { 2 }
+sub SEM_NOOPENFILEERRORBOX () { 32768 }
+sub TRUNCATE_EXISTING () { 5 }
+sub Unknown () { 0 }
+sub VALID_NTFT () { 192 }
+1;
diff --git a/Master/tlpkg/tlperl/lib/Win32API/Registry.pm b/Master/tlpkg/tlperl/lib/Win32API/Registry.pm
new file mode 100644
index 00000000000..2a1657c3b5b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32API/Registry.pm
@@ -0,0 +1,1775 @@
+# Registry.pm -- Low-level access to functions/constants from WINREG.h
+
+package Win32API::Registry;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL);
+$VERSION= '0.32';
+
+require Exporter;
+require DynaLoader;
+@ISA= qw(Exporter DynaLoader);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( regConstant regLastError
+ AllowPriv AbortSystemShutdown InitiateSystemShutdown
+ RegCloseKey RegConnectRegistry RegCreateKey
+ RegCreateKeyEx RegDeleteKey RegDeleteValue
+ RegEnumKey RegEnumKeyEx RegEnumValue
+ RegFlushKey RegGetKeySecurity RegLoadKey
+ RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx
+ RegQueryInfoKey RegQueryMultipleValues RegQueryValue
+ RegQueryValueEx RegReplaceKey RegRestoreKey
+ RegSaveKey RegSetKeySecurity RegSetValue
+ RegSetValueEx RegUnLoadKey )],
+ FuncA => [qw(
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA )],
+ FuncW => [qw(
+ AbortSystemShutdownW InitiateSystemShutdownW
+ RegConnectRegistryW RegCreateKeyW RegCreateKeyExW
+ RegDeleteKeyW RegDeleteValueW RegEnumKeyW
+ RegEnumKeyExW RegEnumValueW RegLoadKeyW
+ RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW
+ RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW
+ RegReplaceKeyW RegRestoreKeyW RegSaveKeyW
+ RegSetValueW RegSetValueExW RegUnLoadKeyW )],
+ HKEY_ => [qw(
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS )],
+ KEY_ => [qw(
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS),
+ 'KEY_DELETE', # DELETE (0x00010000L)
+ 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L)
+ 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L)
+ 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L)
+ 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used)
+ ],
+ REG_ => [qw(
+ REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE
+ REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE
+ REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY
+ REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER
+ REG_NONE REG_SZ REG_EXPAND_SZ
+ REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST )],
+ SE_ => [qw(
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )],
+);
+@EXPORT_OK= ();
+{ my $ref;
+ foreach $ref ( values(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/;
+ }
+}
+$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down.
+# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl
+push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} );
+
+bootstrap Win32API::Registry $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cRegistry.pc
+# [instead of C or C++ code in cRegistry.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs>
+# or make F<cRegistry.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined &REG_NONE ) {
+ require "Win32API/Registry/cRegistry.pc";
+}
+
+# This would be convenient but inconsistant and hard to explain:
+#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} )
+# if defined &SE_TCB_NAME;
+
+sub regConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= regConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+BEGIN {
+ my $code= 'return _regLastError(@_)';
+ local( $!, $^E )= ( 1, 1 );
+ if( $! ne $^E ) {
+ $code= '
+ local( $^E )= _regLastError(@_);
+ my $ret= $^E;
+ return $ret;
+ ';
+ }
+ eval "sub regLastError { $code }";
+ die "$@" if $@;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::Registry->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::Registry" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Let user omit all buffer sizes:
+sub RegEnumKeyExA {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExA;
+}
+sub RegEnumKeyExW {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExW;
+}
+sub RegEnumValueA {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueA;
+}
+sub RegEnumValueW {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueW;
+}
+sub RegQueryInfoKeyA {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyA;
+}
+sub RegQueryInfoKeyW {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyW;
+}
+
+sub RegEnumKeyA {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyA;
+}
+sub RegEnumKeyW {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyW;
+}
+sub RegGetKeySecurity {
+ push(@_,[]) if 3 == @_;
+ &_RegGetKeySecurity;
+}
+sub RegQueryMultipleValuesA {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesA;
+}
+sub RegQueryMultipleValuesW {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesW;
+}
+sub RegQueryValueA {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueA;
+}
+sub RegQueryValueW {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueW;
+}
+sub RegQueryValueExA {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExA;
+}
+sub RegQueryValueExW {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExW;
+}
+sub RegSetValueA {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueA;
+}
+sub RegSetValueW {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueW;
+}
+sub RegSetValueExA {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExA;
+}
+sub RegSetValueExW {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExW;
+}
+
+# Aliases for non-Unicode functions:
+sub AbortSystemShutdown { &AbortSystemShutdownA; }
+sub InitiateSystemShutdown { &InitiateSystemShutdownA; }
+sub RegConnectRegistry { &RegConnectRegistryA; }
+sub RegCreateKey { &RegCreateKeyA; }
+sub RegCreateKeyEx { &RegCreateKeyExA; }
+sub RegDeleteKey { &RegDeleteKeyA; }
+sub RegDeleteValue { &RegDeleteValueA; }
+sub RegEnumKey { &RegEnumKeyA; }
+sub RegEnumKeyEx { &RegEnumKeyExA; }
+sub RegEnumValue { &RegEnumValueA; }
+sub RegLoadKey { &RegLoadKeyA; }
+sub RegOpenKey { &RegOpenKeyA; }
+sub RegOpenKeyEx { &RegOpenKeyExA; }
+sub RegQueryInfoKey { &RegQueryInfoKeyA; }
+sub RegQueryMultipleValues { &RegQueryMultipleValuesA; }
+sub RegQueryValue { &RegQueryValueA; }
+sub RegQueryValueEx { &RegQueryValueExA; }
+sub RegReplaceKey { &RegReplaceKeyA; }
+sub RegRestoreKey { &RegRestoreKeyA; }
+sub RegSaveKey { &RegSaveKeyA; }
+sub RegSetValue { &RegSetValueA; }
+sub RegSetValueEx { &RegSetValueExA; }
+sub RegUnLoadKey { &RegUnLoadKeyA; }
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H
+
+=head1 SYNOPSIS
+
+ use Win32API::Registry 0.21 qw( :ALL );
+
+ RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key );
+ or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+ RegQueryValueEx( $key, "Information", [], $type, $data, [] );
+ or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ",
+ regLastError(),"\n";
+ [...]
+ RegCloseKey( $key )
+ or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with the Registry [mostly from WINREG.H]. This
+is mostly intended to be used by other modules such as
+C<Win32::TieRegistry> [which provides an extremely Perl-friendly
+method for using the Registry].
+
+For a description of the logical structure of the Registry, see
+the documentation for the C<Win32::TieRegistry> module.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All calls return a true value for success and a false value for
+failure. After any failure, C<$^E> should automatically be set
+to indicate the reason. However, current versions of Perl often
+overwrite C<$^E> too quickly, so you can use C<regLastError()>
+instead, which is only set by Win32API::Registry routines.
+C<regLastError()> is also good if you have a really old version
+of Perl that does not connect C<$^E> to C<GetLastError()> on
+Win32.
+
+Note that C<$!> is not set by these routines except by
+C<Win32API::Registry::constant()> when a constant is not defined.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have sets of symbols exported.
+
+[Note that much of the following documentation refers to the
+behavior of the underlying API calls which may vary in current
+and future versions of the Win32 API without any changes to this
+module. Therefore you should check the Win32 API documentation
+directly when needed.]
+
+=over
+
+=item :Func
+
+The basic function names:
+
+=over
+
+=item AllowPriv
+
+=item C<AllowPriv( $sPrivName, $bEnable )>
+
+Not a Win32 API call. Enables or disables a specific privilege for
+the current process. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure. This routine
+does not provide a way to tell if a privilege is currently enabled.
+
+C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example,
+C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether
+you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a.
+C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>.
+
+If C<$bEnable> is true, then C<AllowPriv()> tries to enable the
+privilege. Otherwise it tries to disable the privilege.
+
+=item AbortSystemShutdown
+
+=item C<AbortSystemShutdown( $sComputerName )>
+
+Tries to abort a remote shutdown request previously made via
+C<InitiateSystemShutdown()>. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+=item InitiateSystemShutdown
+
+=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+Requests that a [remote] computer be shutdown or rebooted.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of the computer to be
+shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<"">
+to indicate the local computer.
+
+C<$sMessage> is the message to be displayed in a pop-up window
+on the desktop of the computer to be shutdown or rebooted until
+the timeout expires or the shutdown is aborted via
+C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the
+message will never be visible.
+
+C<$iTimeoutSecs> is the number of seconds to wait before starting
+the shutdown.
+
+If C<$bForce> is false, then any applications running on the remote
+computer get a chance to prompt the remote user whether they want
+to save changes. Also, for any applications that do not exit quickly
+enough, the operating system will prompt the user whether they wish
+to wait longer for the application to exit or force it to exit now.
+At any of these prompts the user can press B<CANCEL> to abort the
+shutdown but if no applications have unsaved data, they will likely
+all exit quickly and the shutdown will progress with the remote user
+having no option to cancel the shutdown.
+
+If C<$bForce> is true, all applications are told to exit immediately
+and so will not prompt the user even if there is unsaved data. Any
+applications that take too long to exit will be forcibly killed after
+a short time. The only way to abort the shutdown is to call
+C<AbortSystemShutdown()> before the timeout expires and there is no
+way to abort the shutdown once it has begun.
+
+If C<$bReboot> is true, the computer will automatically reboot once
+the shutdown is complete. If C<$bReboot> is false, then when the
+shutdown is complete the computer will halt at a screen indicating
+that the shutdown is complete and offering a way for the user to
+start to boot the computer.
+
+You must have the C<"SeRemoteShutdownPrivilege"> privilege
+on the remote computer for this call to succeed. If shutting
+down the local computer, then the calling process must have
+the C<"SeShutdownPrivilege"> privilege and have it enabled.
+
+=item RegCloseKey
+
+=item C<RegCloseKey( $hKey )>
+
+Closes the handle to a Registry key returned by C<RegOpenKeyEx()>,
+C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other
+routines. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+=item RegConnectRegistry
+
+=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )>
+
+Connects to one of the root Registry keys of a remote computer.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of a remote computer
+whose Registry you wish to access.
+
+C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS>
+and specifies which root Registry key on the remote computer
+you wish to have access to.
+
+C<$phKey> will be set to the handle to be used to access the
+remote Registry key if the call succeeds.
+
+=item regConstant
+
+=item C<$value= regConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::Registry> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item RegCreateKey
+
+=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegCreateKeyEx()> instead.
+
+=item RegCreateKeyEx
+
+=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+Creates a new Registry subkey. Returns a true value if successful and
+a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the new subkey to be created.
+
+C<$iZero> is reserved for future use and should always be specified
+as C<0>.
+
+C<$sClass> is a string to be used as the class for the new
+subkey. We are not aware of any current use for Registry key
+class information so the empty string, C<"">, should usually
+be used here.
+
+C<$iOpts> is a numeric value containing bits that control options
+used while creating the new subkey. C<REG_OPTION_NON_VOLATILE>
+is the default. C<REG_OPTION_VOLATILE> [which is ignored on
+Windows 95] means the data stored under this key is not kept
+in a file and will not be preserved when the system reboots.
+C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means
+ignore the C<$iAccess> parameter and try to open the new key with
+the access required to backup or restore the key.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. See C<RegOpenKeyEx()>.
+
+C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into
+a Perl string which controls whether the returned handle can be
+inherited by child processes. Normally you would pass C<[]> for
+this parameter to have C<NULL> passed to the underlying API
+indicating that the handle cannot be inherited. If not under
+Windows95, then C<$pSecAttr> also allows you to specify
+C<SECURITY_DESCRIPTOR> that controls which users will have
+what type of access to the new key -- otherwise the new key
+inherits its security from its parent key.
+
+C<$phKey> will be set to the handle to be used to access the new
+subkey if the call succeeds.
+
+C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or
+C<REG_OPENED_EXISTING_KEY> to indicate for which reason the
+call succeeded. Can be specified as C<[]> if you don't care.
+
+If C<$phKey> and C<$piDisp> start out as integers, then they will
+probably remain unchanged if the call fails.
+
+=item RegDeleteKey
+
+=item C<RegDeleteKey( $hKey, $sSubKey )>
+
+Deletes a subkey of an open Registry key provided that the subkey
+contains no subkeys of its own [but the subkey may contain values].
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the subkey to be deleted.
+
+=item RegDeleteValue
+
+=item C<RegDeleteValue( $hKey, $sValueName )>
+
+Deletes a value from an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueKey> is the name of the value to be deleted.
+
+=item RegEnumKey
+
+=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegEnumKeyEx()> instead.
+
+=item RegEnumKeyEx
+
+=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )>
+
+Lets you enumerate the names of all of the subkeys directly under
+an open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the immediate subkey that
+you want information on. Start with this value as C<0> then
+repeat the call incrementing this value each time until the
+call fails with C<$^E>/C<regLastError()> numerically equal to
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sName> will be set to the name of the subkey. Can be C<[]> if
+you don't care about the name.
+
+C<$plName> initially specifies the [minimum] buffer size to be
+allocated for C<$sName>. Will be set to the length of the subkey
+name if the requested subkey exists even if C<$sName> isn't
+successfully set to the subkey name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$sClass> will be set to the class name for the subkey. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+subkey class name if the requested subkey exists. See L<Buffer
+sizes> for more information.
+
+C<$pftLastWrite> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when the subkey was last changed.
+Can be C<[]>.
+
+You may omit both C<$plName> and C<$plClass> to get the same effect
+as passing in C<[]> for each of them.
+
+=item RegEnumValue
+
+=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )>
+
+Lets you enumerate the names of all of the values contained in an
+open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the value that you want
+information on. Start with this value as C<0> then repeat the
+call incrementing this value each time until the call fails with
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sValName> will be set to the name of the value. Can be C<[]>
+if you don't care about the name.
+
+C<$plValName> initially specifies the [minimum] buffer size to be
+allocated for C<$sValName>. Will be set to the length of the value
+name if the requested value exists even if C<$sValName> isn't
+successfully set to the value name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$piType> will be set to the type of data stored in the value data.
+If the call succeeds, it will be set to a C<REG_*> value unless
+passed in as C<[]>.
+
+C<$pValData> will be set to the data [packed into a Perl string]
+that is stored in the requested value. Can be C<[]> if you don't
+care about the value data.
+
+C<$plValData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValData> and will be set to the length of the
+value data if the requested value exists. See L<Buffer sizes> for
+more information.
+
+You may omit both C<$plValName> and C<$plValData> to get the same
+effect as passing in C<[]> for each of them.
+
+=item RegFlushKey
+
+=item C<RegFlushKey( $hKey )>
+
+Forces the data stored under an open Registry key to be flushed
+to the disk file where the data is preserved between reboots.
+Forced flushing is not guaranteed to be efficient so this routine
+should almost never be called. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+=item RegGetKeySecurity
+
+=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )>
+
+Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing
+part of the security for an open Registry key. Returns a true value
+if successful and a false value [and sets C<$^E>/C<regLastError()>]
+on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which parts of the C<SECURITY_DESCRIPTOR> structure
+to retrieve. Should be C<OWNER_SECURITY_INFORMATION>,
+C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or
+or C<SACL_SECURITY_INFORMATION> or two or more of these bits
+combined using C<|>.
+
+C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR>
+structure [packed into a Perl string].
+
+C<$plSecDesc> initially specifies the [minimum] buffer size to be
+allocated for C<$sSecDesc> and will be set to the length of the
+security descriptor. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+=item regLastError
+
+=item C<$svError= regLastError();>
+
+=item C<regLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<regLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= regLastError()> causes C<$x>
+to give different values in string vs. numeric contexts]. On old
+versions of Perl where C<$^E> isn't tied to C<GetLastError()>,
+C<regLastError> simply returns the number of the error and you'll
+need to use <Win32::FormatMessage> to get the error string.
+
+The last form sets the error returned by future calls to
+C<regLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item RegLoadKey
+
+=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )>
+
+Loads a hive file. That is, it creates a new subkey in the
+Registry and associates that subkey with a disk file that contains
+a Registry hive so that the new subkey can be used to access the
+keys and values stored in that hive. Hives are usually created
+via C<RegSaveKey()>. Returns a true value if successful and a
+false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that can have hives
+loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the new subkey to created and associated
+with the hive file.
+
+C<$sFileName> is the name of the hive file to be loaded. This
+file name is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file
+system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+WARNING: Loading of hive files via a network share may silently
+corrupt the hive and so should not be attempted [this is a problem
+in at least some versions of the underlying API which this module
+does not try to fix or avoid]. To access a hive file located on a
+remote computer, connect to the remote computer's Registry and load
+the hive via that.
+
+=item RegNotifyChangeKeyValue
+
+=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )>
+
+Arranges for your process to be notified when part of the Registry
+is changed. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call] for which you wish to be notified when any changes
+are made to it.
+
+If C<$bWatchSubtree> is true, then changes to any subkey or
+descendant of C<$hKey> are also reported.
+
+C<$iNotifyFilter> controllers what types of changes are reported. It
+is a numeric value containing one or more of the following bit masks:
+
+=over
+
+=item C<REG_NOTIFY_CHANGE_NAME>
+
+Notify if a subkey is added or deleted to a monitored key.
+
+=item C<REG_NOTIFY_CHANGE_LAST_SET>
+
+Notify if a value in a monitored key is added, deleted, or modified.
+
+=item C<REG_NOTIFY_CHANGE_SECURITY>
+
+Notify if a security descriptor of a monitored key is changed.
+
+=item C<REG_NOTIFY_CHANGE_ATTRIBUTES>
+
+Notify if any attributes of a monitored key are changed [class
+name or security descriptors].
+
+=back
+
+C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent>
+is a handle to a Win32 I<event> that will be signaled when changes are
+to be reported.
+
+If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns
+immediately and uses C<$hEvent> to notify your process of changes.
+If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does
+not return until there is a change to be notified of.
+
+This routine does not work with Registry keys on remote computers.
+
+=item RegOpenKey
+
+=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegOpenKeyEx()> instead.
+
+=item RegOpenKeyEx
+
+=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+Opens an existing Registry key. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of an existing subkey to be opened.
+Can be C<""> or C<[]> to open an additional handle to the
+key specified by C<$hKey>.
+
+C<$iOptions> is a numeric value containing bits that control options
+used while opening the subkey. There are currently no supported
+options so this parameter should be specified as C<0>.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. Should be a
+combination of one or more of the following bit masks:
+
+=over
+
+=item C<KEY_ALL_ACCESS>
+
+ KEY_READ | KEY_WRITE | KEY_CREATE_LINK
+
+=item C<KEY_READ>
+
+ KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ
+
+=item C<KEY_WRITE>
+
+ KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE
+
+=item C<KEY_QUERY_VALUE>
+
+=item C<KEY_SET_VALUE>
+
+=item C<KEY_ENUMERATE_SUB_KEYS>
+
+=item C<KEY_CREATE_SUB_KEY>
+
+=item C<KEY_NOTIFY>
+
+Allows you to use C<RegNotifyChangeKeyValue()> on the opened key.
+
+=item C<KEY_EXECUTE>
+
+Same as C<KEY_READ>.
+
+=item C<KEY_CREATE_LINK>
+
+Gives you permission to create a symbolic link like
+C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for
+doing so is not documented [and probably requires use of the mostly
+undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>].
+
+=back
+
+C<$phKey> will be set to the handle to be used to access the new subkey
+if the call succeeds.
+
+=item RegQueryInfoKey
+
+=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )>
+
+Gets miscellaneous information about an open Registry key.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sClass> will be set to the class name for the key. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+key's class name. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+C<$pNull> is reserved for future use and should be passed as C<[]>.
+
+C<$pcSubKeys> will be set to the count of the number of subkeys
+directly under this key. Can be C<[]>.
+
+C<$plSubKey> will be set to the length of the longest subkey name.
+Can be C<[]>.
+
+C<$plSubClass> will be set to the length of the longest class name
+used with an immediate subkey of this key. Can be C<[]>.
+
+C<$pcValues> will be set to the count of the number of values in
+this key. Can be C<[]>.
+
+C<$plValName> will be set to the length of the longest value name
+in this key. Can be C<[]>.
+
+C<$plValData> will be set to the length of the longest value data
+in this key. Can be C<[]>.
+
+C<$plSecDesc> will be set to the length of this key's full security
+descriptor.
+
+C<$pftTime> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when this key was last changed.
+Can be C<[]>.
+
+=item RegQueryMultipleValues
+
+=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+Allows you to use a single call to query several values from a single
+open Registry key to maximize efficiency. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$pValueEnts> should contain a list of C<VALENT> structures packed
+into a single Perl string. Each C<VALENT> structure should have
+the C<ve_valuename> entry [the first 4 bytes] pointing to a string
+containing the name of a value stored in this key. The remaining
+fields are set if the function succeeds.
+
+C<$cValueEnts> should contain the count of the number of C<VALENT>
+structures contained in C<$pValueEnts>.
+
+C<$pBuffer> will be set to the data from all of the requested values
+concatenated into a single Perl string.
+
+C<$plBuffer> initially specifies the [minimum] buffer size to be
+allocated for C<$sBuffer> and will be set to the total length of
+the data to be written to C<$sBuffer>. See L<Buffer sizes> for
+more information. You may omit this parameter to get the same
+effect as passing in C<[]> for it.
+
+Here is sample code to populate C<$pValueEnts>:
+
+ # @ValueNames= ...list of value name strings...;
+ $cValueEnts= @ValueNames;
+ $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames );
+
+Here is sample code to retrieve the data type and data length
+returned in C<$pValueEnts>:
+
+ @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts );
+ @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts );
+
+Given the above, and assuming you haven't modified C<$sBuffer> since
+the call, you can also extract the value data strings from C<$sBuffer>
+by using the pointers returned in C<$pValueEnts>:
+
+ @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ),
+ $pValueEnts );
+
+Much better is to use the lengths and extract directly from
+C<$sBuffer> using C<unpack()> [or C<substr()>]:
+
+ @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer );
+
+=item RegQueryValue
+
+=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegQueryValueEx()> instead. This routine can only
+query unamed values [a.k.a. "default values"], that is, values with
+a name of C<"">.
+
+=item RegQueryValueEx
+
+=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )>
+
+Lets you look up value data stored in an open Registry key by
+specifying the value name. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueName> is the name of the value whose data you wish to
+retrieve.
+
+C<$pNull> this parameter is reserved for future use and should be
+specified as C<[]>.
+
+C<$piType> will be set to indicate what type of data is stored in
+the named value. Will be set to a C<REG_*> value if the function
+succeeds.
+
+C<$pValueData> will be set to the value data [packed into a Perl
+string] that is stored in the named value. Can be C<[]> if you
+don't care about the value data.
+
+C<$plValueData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValueData> and will be set to the size [always
+in bytes] of the data to be written to C<$sValueData>, even if
+C<$sValueData> is not successfully written to. See L<Buffer sizes>
+for more information.
+
+=item RegReplaceKey
+
+=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )>
+
+Lets you replace an entire hive when the system is next booted.
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hive(s)
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>,
+C<HKEY_USERS>, or a remote version of one of these from
+a call to C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey of C<$hKey> whose hive
+you wish to have replaced on the next reboot.
+
+C<$sNewFile> is the name of a file that will replace the existing
+hive file when the system reboots.
+
+C<$sOldFile> is the file name to save the current hive file to
+when the system reboots.
+
+C<$sNewFile> and C<$sOldFile> are interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides [I think]. If either file is [would be]
+on a FAT file system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegRestoreKey
+
+=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )>
+
+Reads in a hive file and copies its contents over an existing
+Registry tree. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the hive file to be read. For each
+value and subkey in this file, a value or subkey will be added
+or replaced in C<$hKey>.
+
+C<$uFlags> is usally C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE>
+which, rather than copying the hive over the existing key,
+replaces the existing key with a temporary, memory-only Registry
+key and then copies the hive contents into it. This option only
+works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a
+remote version of one of these from a call to C<RegConnectRegistry()>.
+
+C<RegRestoreKey> does I<not> delete values nor keys from the
+existing Registry tree when there is no corresponding value/key
+in the hive file.
+
+=item RegSaveKey
+
+=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )>
+
+Dumps any open Registry key and all of its subkeys and values into
+a new hive file. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the file that the Registry tree
+should be saved to. It is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file system,
+then it must not have an extension.
+
+C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies
+the permissions to be set on the new file that is created. This can
+be C<[]>.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegSetKeySecurity
+
+=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )>
+
+Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part
+of the security for an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which C<SECURITY_DESCRIPTOR> structure to set. Should
+be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>,
+C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION>
+or two or more of these bits combined using C<|>.
+
+C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure
+packed into a Perl string.
+
+=item RegSetValue
+
+=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegSetValueEx()> instead. This routine can only
+set unamed values [a.k.a. "default values"].
+
+=item RegSetValueEx
+
+=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )>
+
+Adds or replaces a value in an open Registry key. Returns
+a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sName> is the name of the value to be set.
+
+C<$uZero> is reserved for future use and should be specified as C<0>.
+
+C<$uType> is the type of data stored in C<$pData>. It should
+be a C<REG_*> value.
+
+C<$pData> is the value data packed into a Perl string.
+
+C<$lData> is the length of the value data that is stored in C<$pData>.
+You will usually omit this parameter or pass in C<0> to have
+C<length($pData)> used. In both of these cases, if C<$iType> is
+C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a
+trailing C<'\0'> to the end of C<$pData> [unless there is already
+one].
+
+=item RegUnLoadKey
+
+=item C<RegUnLoadKey( $hKey, $sSubKey )>
+
+Unloads a previously loaded hive file. That is, closes the
+hive file then deletes the subkey that was providing access
+to it. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hives
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey whose hive you wish to
+have unloaded.
+
+=item :FuncA
+
+The ASCII-specific function names.
+
+Each of these is identical to the version listed above without the
+trailing "A":
+
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA
+
+=item :FuncW
+
+The UNICODE-specific function names. These are the same as the
+versions listed above without the trailing "W" except that string
+parameters are UNICODE strings rather than ASCII strings, as
+indicated.
+
+=item AbortSystemShutdownW
+
+=item C<AbortSystemShutdownW( $swComputerName )>
+
+C<$swComputerName> is UNICODE.
+
+=item InitiateSystemShutdownW
+
+=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+C<$swComputer> and C<$swMessage> are UNICODE.
+
+=item RegConnectRegistryW
+
+=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )>
+
+C<$swComputer> is UNICODE.
+
+=item RegCreateKeyW
+
+=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegCreateKeyExW
+
+=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+C<$swSubKey> and C<$swClass> are UNICODE.
+
+=item RegDeleteKeyW
+
+=item C<RegDeleteKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegDeleteValueW
+
+=item C<RegDeleteValueW( $hKey, $swValueName )>
+
+C<$swValueName> is UNICODE.
+
+=item RegEnumKeyW
+
+=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )>
+
+C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of
+C<WCHAR>s.
+
+=item RegEnumKeyExW
+
+=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )>
+
+C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass>
+are measured as number of C<WCHAR>s.
+
+=item RegEnumValueW
+
+=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )>
+
+C<$oswName> is UNICODE and C<$iolwName> is measured as number
+of C<WCHAR>s.
+
+C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number
+of bytes even in these cases.
+
+=item RegLoadKeyW
+
+=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )>
+
+C<$swSubKey> and C<$swFileName> are UNICODE.
+
+=item RegOpenKeyW
+
+=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegOpenKeyExW
+
+=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegQueryInfoKeyW
+
+=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )>
+
+C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>,
+and C<$olwValName> are measured as number of C<WCHAR>s. Note that
+C<$olValData> is measured as number of bytes.
+
+=item RegQueryMultipleValuesW
+
+=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>]
+structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>,
+C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer>
+in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields
+of the C<VALENT> [C<VALENTW>] structures are measured as number of
+bytes.
+
+=item RegQueryValueW
+
+=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )>
+
+C<$swSubKey> and C<$oswValueData> are UNICODE. Note that
+C<$iolValueData> is measured as number of bytes.
+
+=item RegQueryValueExW
+
+=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )>
+
+C<$swName> is UNICODE.
+
+C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of
+bytes even in these cases.
+
+=item RegReplaceKeyW
+
+=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )>
+
+C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE.
+
+=item RegRestoreKeyW
+
+=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSaveKeyW
+
+=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSetValueW
+
+=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )>
+
+C<$swSubKey> and C<$swValueData> are UNICODE. Note that
+C<$lValueData> is measured as number of bytes even though
+C<$swValueData> is always UNICODE.
+
+=item RegSetValueExW
+
+=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )>
+
+C<$swName> is UNICODE.
+
+C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of
+bytes even in these cases.
+
+=item RegUnLoadKeyW
+
+=item C<RegUnLoadKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item :HKEY_
+
+All C<HKEY_*> constants:
+
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS
+
+=item :KEY_
+
+All C<KEY_*> constants:
+
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS
+
+=item :REG_
+
+All C<REG_*> constants:
+
+ REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY
+
+ REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION
+
+ REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK
+ REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK
+ REG_OPTION_RESERVED REG_OPTION_VOLATILE
+
+ REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH
+
+ REG_NONE REG_SZ
+ REG_EXPAND_SZ REG_BINARY
+ REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK
+ REG_MULTI_SZ REG_RESOURCE_LIST
+ REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST
+
+=item :ALL
+
+All of the above.
+
+=item :SE_
+
+The strings for the following privilege names:
+
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME
+
+It can be difficult to successfully build this module in a way
+that makes these constants available. So some builds of this
+module may not make them available. For such builds, trying
+to export any of these constants will cause a fatal error.
+For this reason, none of these symbols are currently included
+in the C<":ALL"> grouping.
+
+=back
+
+=back
+
+=head2 The Win32API:: heirarchy
+
+This and the other Win32API:: modules are meant to expose the
+nearly raw API calls so they can be used from Perl code in any
+way they might be used from C code. This provides the following
+advantages:
+
+=over
+
+=item Many modules can be written by people that don't have a C compiler.
+
+=item Encourages more module code to be written in Perl [not C].
+
+Perl code is often much easier to inspect, debug, customize, and
+enhance than XS code.
+
+=item Allows those already familiar with the Win32 API to get
+off to a quick start.
+
+=item Provides an interactive tool for exploring even obscure
+details of the Win32 API.
+
+It can be very useful to interactively explore ad-hoc calls into
+parts of the Win32 API using:
+
+ perl -de 0
+
+=item Ensures that native Win32 data structures can be used.
+
+This allows maximum efficiency. It also allows data from one
+module [for example, time or security information from the
+C<Win32API::Registry> or C<Win32API::File> modules] to be used
+with other modules [for example, C<Win32API::Time> and
+C<Win32API::SecDesc>].
+
+=item Provides a single version of the XS interface to each API
+call where improvements can be collected.
+
+=back
+
+=head2 Buffer sizes
+
+For each parameter that specifies a buffer size, a value of C<0>
+can be passed. For parameter that are pointers to buffer sizes,
+you can also pass in C<NULL> by specifying an empty list reference,
+C<[]>. Both of these cases will ensure that the variable has
+I<some> buffer space allocated to it and pass in that buffer's
+allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>,
+that the buffer size was not sufficient and the F<Registry.xs>
+code will automatically enlarge the buffer to the required size
+and repeat the call.
+
+Numeric buffer sizes are used as minimum initial sizes for the
+buffers. The larger of this size and the size of space already
+allocated to the scalar will be passed to the underlying routine.
+If that size was insufficient, and the underlying call provides
+an easy method for determining the needed buffer size, then the
+buffer will be enlarged and the call repeated as above.
+
+The underlying calls define buffer size parameter as unsigned, so
+negative buffer sizes are treated as very large positive buffer
+sizes which usually cause C<malloc()> to fail.
+
+To force the F<Registry.xs> code to pass in a specific value for
+a buffer size, preceed the size with an equals sign via C<"=".>.
+Buffer sizes that are passed in as strings starting with an equals
+sign will have the equal sign stripped and the remainder of the string
+interpretted as a number [via C's C<strtoul()> using only base 10]
+which will be passed to the underlying routine [even if the allocated
+buffer is actually larger]. The F<Registry.xs> code will enlarge the
+buffer to the specified size, if needed, but will not enlarge the
+buffer based on the underlying routine requesting more space.
+
+Some Reg*() calls may not currently set the buffer size when they
+return C<ERROR_MORE_DATA>. But some that are not documented as
+doing so, currently do so anyway. So the code assumes that any
+routine I<might> do this and resizes any buffers and repeats the
+call. We hope that eventually all routines will provide this
+feature.
+
+When you use C<[]> for a buffer size, you can still find the
+length of the data returned by using C<length($buffer)>. Note
+that this length will be in bytes while a few of the buffer
+sizes would have been in units of wide characters.
+
+Note that the RegQueryValueEx*() and RegEnumValue*() calls
+will trim the trailing C<'\0'> [if present] from the returned data
+values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the
+value data length parameter is omitted [or specified as C<[]>].
+
+The RegSetValueEx*() calls will add a trailing C<'\0'> [if
+missing] to the supplied data values of type C<REG_SZ> and
+C<REG_EXPAND_SZ> but only if the value data length parameter
+is omitted [or specified as C<0>].
+
+=head2 Hungarian Notation
+
+The following abbreviations are used at the start of each parameter
+name to hint at aspects of how the parameter is used. The prefix
+is always in lower case and followed by a capital letter that starts
+the descriptive part of the parameter name. Several of the following
+abbreviations can be combined into a single prefix.
+
+Probably not all of these prefix notations are used by this module.
+This document section may be included in any C<Win32API> module and
+so covers some notations not used by this specific module.
+
+=over
+
+=item s
+
+A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a
+string except that it will be truncated at the first C<"\0">, if
+it contains one.
+
+=item sw
+
+A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>.
+In Perl, a string that contains UNICODE data. You can convert a
+string to UNICODE in Perl via:
+
+ $string= "This is an example string";
+ $unicode= pack( "S*", unpack("C*",$string), 0 );
+
+Note how C<, 0> above causes an explicit C<L'\0'> to be added since
+Perl's implicit C<'\0'> that it puts after each of its strings is not
+wide enough to terminate a UNICODE string. So UNICODE strings are
+different than regular strings in that the Perl version of a regular
+string will not include the trialing C<'\0'> while the Perl version
+of a UNICODE string must include the trailing C<L'\0'>.
+
+If a UNICODE string contains no non-ASCII characters, then you
+can convert it back into a normal string via:
+
+ $string= pack( "C*", unpack("S*",$unicode) );
+ $string =~ s/\0$//;
+
+=item p
+
+A pointer to some buffer [usually containing some C<struct>]. In C,
+a C<void *> or some other pointer type. In Perl, a string that is
+usually manipulated using C<pack> and C<unpack>. The "p" is usually
+followed by more prefix character(s) to indicate what type of data is
+stored in the bufffer.
+
+=item a
+
+A packed array. In C, an array [usually of C<struct>s]. In Perl, a
+string containing the packed data. The "a" is usually followed by
+more prefix character(s) to indicate the data type of the elements.
+
+These packed arrays are also called "vectors" in places to avoid
+confusion with Perl arrays.
+
+=item n
+
+A generic number. In C, any of the integer or floating point data
+types. In Perl, a number; either an integer, unsigned, or double
+[IV, UV, or NV, respectively]. Usually an integer.
+
+=item iv
+
+A signed integral value. In C, any of the signed integer data types.
+In Perl, an integer [IV].
+
+=item u
+
+An unsigned integral value. In C, any of the unsigned integer data
+types. In Perl, an unsigned integer [UV].
+
+=item d
+
+A floating-point number. In C, a C<float> or C<double> or, perhaps,
+a C<long double>. In Perl, a double-precision floating-point number
+[NV].
+
+=item b
+
+A Boolean value. In C, any integer data type, though usually via
+a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or
+non-zero [true] value. In Perl, a scalar containing a Boolean value
+[C<0>, C<"">, or C<undef> for "false" and anything else for "true"].
+
+=item c
+
+A count of items. In C, any integer data type. In Perl, an unsigned
+integer [UV]. Usually used in conjunction with a "vector" parameter
+[see L</a> above] to indicate the number of elements.
+
+=item l
+
+A length [in bytes]. In C, any integer data type. In Perl, an
+unsigned integer [UV]. Usually used in conjunction with a "string"
+or "pointer" parameter [see L</s> and L</p> above] to indicate the
+buffer size or the size of the value stored in the buffer.
+
+For strings, there is no general rule as to whether the trailing
+C<'\0'> is included in such sizes. For this reason, the C<Win32API>
+modules follow the Perl rule of always allocating one extra byte
+and reporting buffer sizes as being one smaller than allocated in
+case the C<'\0'> is not included in the size.
+
+=item lw
+
+A length measured as number of UNICODE characters. In C, a count
+of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts"
+[see "s" and "S" in C<pack> and C<unpack>].
+
+For UNICODE strings, the trailing C<L'\0'> may or may not be
+included in a length so, again, we always allocate extra room
+for one and don't report that extra space.
+
+=item h
+
+A handle. In C, a C<HANDLE> or more-specific handle data type.
+In Perl, an unsigned integer [UV]. In C, these handles are often
+actually some type of pointer, but Perl just treats them as opaque
+numbers, as it should. This prefix is also used for other pointers
+that are treated as integers in Perl code.
+
+=item r
+
+A record. In C, almost always a C<struct> or perhaps C<union>. Note
+that C C<struct>s are rarely passed by value so the "r" is almost
+always preceeded by a "p" or "a" [see L</p> and L</a> above]. For
+the very rare unadorned "r", Perl stores the record in the same way
+as a "pr", that is, in a string. For the very rare case where Perl
+explicitly stores a pointer to the C<struct> rather than storing the
+C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even
+"par" is used.
+
+=item sv
+
+=item rv
+
+=item hv
+
+=item av
+
+=item cv
+
+A Perl data type. Respectively, a scalar value [SV], a reference
+[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl
+code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a
+leading "rv" is usually assumed. For a parameter to an XS subroutine,
+a prefix of "sv" means the parameter is a scalar and so may be a string
+or a number [or C<undef>] or even both at the same time. So "sv"
+doesn't imply a leading "rv".
+
+=item Input or Output
+
+Whether a parameter is for input data, output data, or both is usually
+not reflected by the data type prefix. In cases where this is not
+obvious nor reflected in the parameter name proper, we may use the
+following in front of the data type prefix.
+
+=over
+
+=item i
+
+An input parameter given to the API [usually omitted].
+
+=item o
+
+An output-only parameter taken from the API. You should not get a
+warning if such a parameter is C<undef> when you pass it into the
+function. You should get an error if such a parameter is read-only.
+You can [usually] pass in C<[]> for such a parameter to have the
+parameter silently ignored.
+
+The output may be written directly into the Perl variable passed
+to the subroutine, the same way the buffer parameter to Perl's
+C<sysread()>. This method is often avoided in Perl because
+the call then lacks any visual cue that some parameters are being
+overwritten. But this method closely matches the C API which is
+what we are trying to do.
+
+=item io
+
+Input given to the API then overwritten with output taken from the
+API. You should get a warning [if B<-w> is in effect] if such a
+parameter is C<undef> when you pass it into the function [unless it
+is a buffer or buffer length parameter]. If the value is read-only,
+then [for most parameters] the output is silently not written. This
+is because it is often convenient to pass in read-only constants for
+many such parameters. You can also usually pass in C<[]> for such
+parameters.
+
+=back
+
+=item pp
+
+=item ppr
+
+=item par
+
+=item pap
+
+These are just unusual combinations of prefix characters described above.
+
+For each, a pointer is stored in a [4-byte] Perl string. You can
+usually use C<unpack "P"> to access the real data from Perl.
+
+For "ppr" [and often for "pp"], the pointer points directly at a
+C C<struct>. For "par", the pointer points to the first element
+of a C [packed] array of C<struct>s. For "pap", the pointer points
+to a C [packed] array of pointers to other things.
+
+=item ap
+
+Here we have a list of pointers packed into a single Perl string.
+
+=back
+
+
+=head1 BUGS
+
+The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the
+ActiveState distributions of standard Perl 5.004 and beyond] do not support
+the tools for building extensions and so do not support this extension.
+
+No routines are provided for using the data returned in the C<FILETIME>
+buffers. Those are in the C<Win32API::Time> module.
+
+No routines are provided for dealing with UNICODE data effectively.
+See L</:FuncW> above for some simple-minded UNICODE methods.
+
+Parts of the module test will fail if used on a version of Perl
+that does not yet set C<$^E> based on C<GetLastError()>.
+
+On NT 4.0 [at least], the RegEnum*() calls do not set the required
+buffer sizes when returning C<ERROR_MORE_DATA> so this module will
+not grow the buffers in such cases. C<Win32::TieRegistry> overcomes
+this by using values from C<RegQueryInfoKey()> for buffer sizes in
+RegEnum* calls.
+
+On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA>
+never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA>
+never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA>
+you will need to keep growing the data buffer until the call succeeds.
+
+Because C<goto &subroutine> seems to be buggy under Win32 Perl,
+it is not used in the stubs in F<Registry.pm>.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Win32::TieRegistry>
+
+=item L<Win32::Registry>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc b/Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc
new file mode 100644
index 00000000000..9659d0c4361
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc
@@ -0,0 +1,87 @@
+# Generated by cRegistry_pc.cxx.
+# Package Win32API::Registry with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/]]
+# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] }
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub HKEY_CLASSES_ROOT () { 0x80000000 }
+sub HKEY_CURRENT_CONFIG () { 0x80000005 }
+sub HKEY_CURRENT_USER () { 0x80000001 }
+sub HKEY_DYN_DATA () { 0x80000006 }
+sub HKEY_LOCAL_MACHINE () { 0x80000002 }
+sub HKEY_PERFORMANCE_DATA () { 0x80000004 }
+sub HKEY_USERS () { 0x80000003 }
+sub KEY_ALL_ACCESS () { 983103 }
+sub KEY_CREATE_LINK () { 32 }
+sub KEY_CREATE_SUB_KEY () { 4 }
+sub KEY_DELETE () { 65536 }
+sub KEY_ENUMERATE_SUB_KEYS () { 8 }
+sub KEY_EXECUTE () { 131097 }
+sub KEY_NOTIFY () { 16 }
+sub KEY_QUERY_VALUE () { 1 }
+sub KEY_READ () { 131097 }
+sub KEY_READ_CONTROL () { 131072 }
+sub KEY_SET_VALUE () { 2 }
+sub KEY_SYNCHRONIZE () { 1048576 }
+sub KEY_WRITE () { 131078 }
+sub KEY_WRITE_DAC () { 262144 }
+sub KEY_WRITE_OWNER () { 524288 }
+sub REG_BINARY () { 3 }
+sub REG_CREATED_NEW_KEY () { 1 }
+sub REG_DWORD () { 4 }
+sub REG_DWORD_BIG_ENDIAN () { 5 }
+sub REG_DWORD_LITTLE_ENDIAN () { 4 }
+sub REG_EXPAND_SZ () { 2 }
+sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 }
+sub REG_LEGAL_CHANGE_FILTER () { 15 }
+sub REG_LEGAL_OPTION () { 15 }
+sub REG_LINK () { 6 }
+sub REG_MULTI_SZ () { 7 }
+sub REG_NONE () { 0 }
+sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 }
+sub REG_NOTIFY_CHANGE_LAST_SET () { 4 }
+sub REG_NOTIFY_CHANGE_NAME () { 1 }
+sub REG_NOTIFY_CHANGE_SECURITY () { 8 }
+sub REG_NO_LAZY_FLUSH () { 4 }
+sub REG_OPENED_EXISTING_KEY () { 2 }
+sub REG_OPTION_BACKUP_RESTORE () { 4 }
+sub REG_OPTION_CREATE_LINK () { 2 }
+sub REG_OPTION_NON_VOLATILE () { 0 }
+sub REG_OPTION_OPEN_LINK () { 8 }
+sub REG_OPTION_RESERVED () { 0 }
+sub REG_OPTION_VOLATILE () { 1 }
+sub REG_REFRESH_HIVE () { 2 }
+sub REG_RESOURCE_LIST () { 8 }
+sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 }
+sub REG_SZ () { 1 }
+sub REG_WHOLE_HIVE_VOLATILE () { 1 }
+sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' }
+sub SE_AUDIT_NAME () { 'SeAuditPrivilege' }
+sub SE_BACKUP_NAME () { 'SeBackupPrivilege' }
+sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' }
+sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' }
+sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' }
+sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' }
+sub SE_DEBUG_NAME () { 'SeDebugPrivilege' }
+sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' }
+sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' }
+sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' }
+sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' }
+sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' }
+sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' }
+sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' }
+sub SE_RESTORE_NAME () { 'SeRestorePrivilege' }
+sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' }
+sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' }
+sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' }
+sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' }
+sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' }
+sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' }
+sub SE_TCB_NAME () { 'SeTcbPrivilege' }
+sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' }
+1;
diff --git a/Master/tlpkg/tlperl/lib/autodie/exception.pm b/Master/tlpkg/tlperl/lib/autodie/exception.pm
new file mode 100644
index 00000000000..8646099c4c8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/exception.pm
@@ -0,0 +1,741 @@
+package autodie::exception;
+use 5.008;
+use strict;
+use warnings;
+use Carp qw(croak);
+
+our $DEBUG = 0;
+
+use overload
+ q{""} => "stringify"
+;
+
+# Overload smart-match only if we're using 5.10
+
+use if ($] >= 5.010), overload => '~~' => "matches";
+
+our $VERSION = '2.06_01';
+
+my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
+
+=head1 NAME
+
+autodie::exception - Exceptions from autodying functions.
+
+=head1 SYNOPSIS
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', 'some_file.txt');
+
+ ...
+ };
+
+ if (my $E = $@) {
+ say "Ooops! ",$E->caller," had problems: $@";
+ }
+
+
+=head1 DESCRIPTION
+
+When an L<autodie> enabled function fails, it generates an
+C<autodie::exception> object. This can be interrogated to
+determine further information about the error that occurred.
+
+This document is broken into two sections; those methods that
+are most useful to the end-developer, and those methods for
+anyone wishing to subclass or get very familiar with
+C<autodie::exception>.
+
+=head2 Common Methods
+
+These methods are intended to be used in the everyday dealing
+of exceptions.
+
+The following assume that the error has been copied into
+a separate scalar:
+
+ if ($E = $@) {
+ ...
+ }
+
+This is not required, but is recommended in case any code
+is called which may reset or alter C<$@>.
+
+=cut
+
+=head3 args
+
+ my $array_ref = $E->args;
+
+Provides a reference to the arguments passed to the subroutine
+that died.
+
+=cut
+
+sub args { return $_[0]->{$PACKAGE}{args}; }
+
+=head3 function
+
+ my $sub = $E->function;
+
+The subroutine (including package) that threw the exception.
+
+=cut
+
+sub function { return $_[0]->{$PACKAGE}{function}; }
+
+=head3 file
+
+ my $file = $E->file;
+
+The file in which the error occurred (eg, C<myscript.pl> or
+C<MyTest.pm>).
+
+=cut
+
+sub file { return $_[0]->{$PACKAGE}{file}; }
+
+=head3 package
+
+ my $package = $E->package;
+
+The package from which the exceptional subroutine was called.
+
+=cut
+
+sub package { return $_[0]->{$PACKAGE}{package}; }
+
+=head3 caller
+
+ my $caller = $E->caller;
+
+The subroutine that I<called> the exceptional code.
+
+=cut
+
+sub caller { return $_[0]->{$PACKAGE}{caller}; }
+
+=head3 line
+
+ my $line = $E->line;
+
+The line in C<< $E->file >> where the exceptional code was called.
+
+=cut
+
+sub line { return $_[0]->{$PACKAGE}{line}; }
+
+=head3 context
+
+ my $context = $E->context;
+
+The context in which the subroutine was called. This can be
+'list', 'scalar', or undefined (unknown). It will never be 'void', as
+C<autodie> always captures the return value in one way or another.
+
+=cut
+
+sub context { return $_[0]->{$PACKAGE}{context} }
+
+=head3 return
+
+ my $return_value = $E->return;
+
+The value(s) returned by the failed subroutine. When the subroutine
+was called in a list context, this will always be a reference to an
+array containing the results. When the subroutine was called in
+a scalar context, this will be the actual scalar returned.
+
+=cut
+
+sub return { return $_[0]->{$PACKAGE}{return} }
+
+=head3 errno
+
+ my $errno = $E->errno;
+
+The value of C<$!> at the time when the exception occurred.
+
+B<NOTE>: This method will leave the main C<autodie::exception> class
+and become part of a role in the future. You should only call
+C<errno> for exceptions where C<$!> would reasonably have been
+set on failure.
+
+=cut
+
+# TODO: Make errno part of a role. It doesn't make sense for
+# everything.
+
+sub errno { return $_[0]->{$PACKAGE}{errno}; }
+
+=head3 eval_error
+
+ my $old_eval_error = $E->eval_error;
+
+The contents of C<$@> immediately after autodie triggered an
+exception. This may be useful when dealing with modules such
+as L<Text::Balanced> that set (but do not throw) C<$@> on error.
+
+=cut
+
+sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
+
+=head3 matches
+
+ if ( $e->matches('open') ) { ... }
+
+ if ( $e ~~ 'open' ) { ... }
+
+C<matches> is used to determine whether a
+given exception matches a particular role. On Perl 5.10,
+using smart-match (C<~~>) with an C<autodie::exception> object
+will use C<matches> underneath.
+
+An exception is considered to match a string if:
+
+=over 4
+
+=item *
+
+For a string not starting with a colon, the string exactly matches the
+package and subroutine that threw the exception. For example,
+C<MyModule::log>. If the string does not contain a package name,
+C<CORE::> is assumed.
+
+=item *
+
+For a string that does start with a colon, if the subroutine
+throwing the exception I<does> that behaviour. For example, the
+C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
+
+See L<autodie/CATEGORIES> for futher information.
+
+=back
+
+=cut
+
+{
+ my (%cache);
+
+ sub matches {
+ my ($this, $that) = @_;
+
+ # TODO - Handle references
+ croak "UNIMPLEMENTED" if ref $that;
+
+ my $sub = $this->function;
+
+ if ($DEBUG) {
+ my $sub2 = $this->function;
+ warn "Smart-matching $that against $sub / $sub2\n";
+ }
+
+ # Direct subname match.
+ return 1 if $that eq $sub;
+ return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
+ return 0 if $that !~ /^:/;
+
+ # Cached match / check tags.
+ require Fatal;
+
+ if (exists $cache{$sub}{$that}) {
+ return $cache{$sub}{$that};
+ }
+
+ # This rather awful looking line checks to see if our sub is in the
+ # list of expanded tags, caches it, and returns the result.
+
+ return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
+ }
+}
+
+# This exists primarily so that child classes can override or
+# augment it if they wish.
+
+sub _expand_tag {
+ my ($this, @args) = @_;
+
+ return Fatal->_expand_tag(@args);
+}
+
+=head2 Advanced methods
+
+The following methods, while usable from anywhere, are primarily
+intended for developers wishing to subclass C<autodie::exception>,
+write code that registers custom error messages, or otherwise
+work closely with the C<autodie::exception> model.
+
+=cut
+
+# The table below records customer formatters.
+# TODO - Should this be a package var instead?
+# TODO - Should these be in a completely different file, or
+# perhaps loaded on demand? Most formatters will never
+# get used in most programs.
+
+my %formatter_of = (
+ 'CORE::close' => \&_format_close,
+ 'CORE::open' => \&_format_open,
+ 'CORE::dbmopen' => \&_format_dbmopen,
+ 'CORE::flock' => \&_format_flock,
+);
+
+# TODO: Our tests only check LOCK_EX | LOCK_NB is properly
+# formatted. Try other combinations and ensure they work
+# correctly.
+
+sub _format_flock {
+ my ($this) = @_;
+
+ require Fcntl;
+
+ my $filehandle = $this->args->[0];
+ my $raw_mode = $this->args->[1];
+
+ my $mode_type;
+ my $lock_unlock;
+
+ if ($raw_mode & Fcntl::LOCK_EX() ) {
+ $lock_unlock = "lock";
+ $mode_type = "for exclusive access";
+ }
+ elsif ($raw_mode & Fcntl::LOCK_SH() ) {
+ $lock_unlock = "lock";
+ $mode_type = "for shared access";
+ }
+ elsif ($raw_mode & Fcntl::LOCK_UN() ) {
+ $lock_unlock = "unlock";
+ $mode_type = "";
+ }
+ else {
+ # I've got no idea what they're trying to do.
+ $lock_unlock = "lock";
+ $mode_type = "with mode $raw_mode";
+ }
+
+ my $cooked_filehandle;
+
+ if ($filehandle and not ref $filehandle) {
+
+ # A package filehandle with a name!
+
+ $cooked_filehandle = " $filehandle";
+ }
+ else {
+ # Otherwise we have a scalar filehandle.
+
+ $cooked_filehandle = '';
+
+ }
+
+ local $! = $this->errno;
+
+ return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
+
+}
+
+# Default formatter for CORE::dbmopen
+sub _format_dbmopen {
+ my ($this) = @_;
+ my @args = @{$this->args};
+
+ # TODO: Presently, $args flattens out the (usually empty) hash
+ # which is passed as the first argument to dbmopen. This is
+ # a bug in our args handling code (taking a reference to it would
+ # be better), but for the moment we'll just examine the end of
+ # our arguments list for message formatting.
+
+ my $mode = $args[-1];
+ my $file = $args[-2];
+
+ # If we have a mask, then display it in octal, not decimal.
+ # We don't do this if it already looks octalish, or doesn't
+ # look like a number.
+
+ if ($mode =~ /^[^\D0]\d+$/) {
+ $mode = sprintf("0%lo", $mode);
+ };
+
+ local $! = $this->errno;
+
+ return "Can't dbmopen(%hash, '$file', $mode): '$!'";
+}
+
+# Default formatter for CORE::close
+
+sub _format_close {
+ my ($this) = @_;
+ my $close_arg = $this->args->[0];
+
+ local $! = $this->errno;
+
+ # If we've got an old-style filehandle, mention it.
+ if ($close_arg and not ref $close_arg) {
+ return "Can't close filehandle '$close_arg': '$!'";
+ }
+
+ # TODO - This will probably produce an ugly error. Test and fix.
+ return "Can't close($close_arg) filehandle: '$!'";
+
+}
+
+# Default formatter for CORE::open
+
+use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
+
+sub _format_open_with_mode {
+ my ($this, $mode, $file, $error) = @_;
+
+ my $wordy_mode;
+
+ if ($mode eq '<') { $wordy_mode = 'reading'; }
+ elsif ($mode eq '>') { $wordy_mode = 'writing'; }
+ elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
+
+ return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
+
+ Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
+
+}
+
+sub _format_open {
+ my ($this) = @_;
+
+ my @open_args = @{$this->args};
+
+ # Use the default formatter for single-arg and many-arg open
+ if (@open_args <= 1 or @open_args >= 4) {
+ return $this->format_default;
+ }
+
+ # For two arg open, we have to extract the mode
+ if (@open_args == 2) {
+ my ($fh, $file) = @open_args;
+
+ if (ref($fh) eq "GLOB") {
+ $fh = '$fh';
+ }
+
+ my ($mode) = $file =~ m{
+ ^\s* # Spaces before mode
+ (
+ (?> # Non-backtracking subexp.
+ < # Reading
+ |>>? # Writing/appending
+ )
+ )
+ [^&] # Not an ampersand (which means a dup)
+ }x;
+
+ if (not $mode) {
+ # Maybe it's a 2-arg open without any mode at all?
+ # Detect the most simple case for this, where our
+ # file consists only of word characters.
+
+ if ( $file =~ m{^\s*\w+\s*$} ) {
+ $mode = '<'
+ }
+ else {
+ # Otherwise, we've got no idea what's going on.
+ # Use the default.
+ return $this->format_default;
+ }
+ }
+
+ # Localising $! means perl make make it a pretty error for us.
+ local $! = $this->errno;
+
+ return $this->_format_open_with_mode($mode, $file, $!);
+ }
+
+ # Here we must be using three arg open.
+
+ my $file = $open_args[2];
+
+ local $! = $this->errno;
+
+ my $mode = $open_args[1];
+
+ local $@;
+
+ my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
+
+ return $msg if $msg;
+
+ # Default message (for pipes and odd things)
+
+ return "Can't open '$file' with mode '$open_args[1]': '$!'";
+}
+
+=head3 register
+
+ autodie::exception->register( 'CORE::open' => \&mysub );
+
+The C<register> method allows for the registration of a message
+handler for a given subroutine. The full subroutine name including
+the package should be used.
+
+Registered message handlers will receive the C<autodie::exception>
+object as the first parameter.
+
+=cut
+
+sub register {
+ my ($class, $symbol, $handler) = @_;
+
+ croak "Incorrect call to autodie::register" if @_ != 3;
+
+ $formatter_of{$symbol} = $handler;
+
+}
+
+=head3 add_file_and_line
+
+ say "Problem occurred",$@->add_file_and_line;
+
+Returns the string C< at %s line %d>, where C<%s> is replaced with
+the filename, and C<%d> is replaced with the line number.
+
+Primarily intended for use by format handlers.
+
+=cut
+
+# Simply produces the file and line number; intended to be added
+# to the end of error messages.
+
+sub add_file_and_line {
+ my ($this) = @_;
+
+ return sprintf(" at %s line %d\n", $this->file, $this->line);
+}
+
+=head3 stringify
+
+ say "The error was: ",$@->stringify;
+
+Formats the error as a human readable string. Usually there's no
+reason to call this directly, as it is used automatically if an
+C<autodie::exception> object is ever used as a string.
+
+Child classes can override this method to change how they're
+stringified.
+
+=cut
+
+sub stringify {
+ my ($this) = @_;
+
+ my $call = $this->function;
+
+ if ($DEBUG) {
+ my $dying_pkg = $this->package;
+ my $sub = $this->function;
+ my $caller = $this->caller;
+ warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
+ }
+
+ # TODO - This isn't using inheritance. Should it?
+ if ( my $sub = $formatter_of{$call} ) {
+ return $sub->($this) . $this->add_file_and_line;
+ }
+
+ return $this->format_default . $this->add_file_and_line;
+
+}
+
+=head3 format_default
+
+ my $error_string = $E->format_default;
+
+This produces the default error string for the given exception,
+I<without using any registered message handlers>. It is primarily
+intended to be called from a message handler when they have
+been passed an exception they don't want to format.
+
+Child classes can override this method to change how default
+messages are formatted.
+
+=cut
+
+# TODO: This produces ugly errors. Is there any way we can
+# dig around to find the actual variable names? I know perl 5.10
+# does some dark and terrible magicks to find them for undef warnings.
+
+sub format_default {
+ my ($this) = @_;
+
+ my $call = $this->function;
+
+ local $! = $this->errno;
+
+ # TODO: This is probably a good idea for CORE, is it
+ # a good idea for other subs?
+
+ # Trim package name off dying sub for error messages.
+ $call =~ s/.*:://;
+
+ # Walk through all our arguments, and...
+ #
+ # * Replace undef with the word 'undef'
+ # * Replace globs with the string '$fh'
+ # * Quote all other args.
+
+ my @args = @{ $this->args() };
+
+ foreach my $arg (@args) {
+ if (not defined($arg)) { $arg = 'undef' }
+ elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
+ else { $arg = qq{'$arg'} }
+ }
+
+ # Format our beautiful error.
+
+ return "Can't $call(". join(q{, }, @args) . "): $!" ;
+
+ # TODO - Handle user-defined errors from hash.
+
+ # TODO - Handle default error messages.
+
+}
+
+=head3 new
+
+ my $error = autodie::exception->new(
+ args => \@_,
+ function => "CORE::open",
+ errno => $!,
+ context => 'scalar',
+ return => undef,
+ );
+
+
+Creates a new C<autodie::exception> object. Normally called
+directly from an autodying function. The C<function> argument
+is required, its the function we were trying to call that
+generated the exception. The C<args> parameter is optional.
+
+The C<errno> value is optional. In versions of C<autodie::exception>
+1.99 and earlier the code would try to automatically use the
+current value of C<$!>, but this was unreliable and is no longer
+supported.
+
+Atrributes such as package, file, and caller are determined
+automatically, and cannot be specified.
+
+=cut
+
+sub new {
+ my ($class, @args) = @_;
+
+ my $this = {};
+
+ bless($this,$class);
+
+ # I'd love to use EVERY here, but it causes our code to die
+ # because it wants to stringify our objects before they're
+ # initialised, causing everything to explode.
+
+ $this->_init(@args);
+
+ return $this;
+}
+
+sub _init {
+
+ my ($this, %args) = @_;
+
+ # Capturing errno here is not necessarily reliable.
+ my $original_errno = $!;
+
+ our $init_called = 1;
+
+ my $class = ref $this;
+
+ # We're going to walk up our call stack, looking for the
+ # first thing that doesn't look like our exception
+ # code, autodie/Fatal, or some whacky eval.
+
+ my ($package, $file, $line, $sub);
+
+ my $depth = 0;
+
+ while (1) {
+ $depth++;
+
+ ($package, $file, $line, $sub) = CORE::caller($depth);
+
+ # Skip up the call stack until we find something outside
+ # of the Fatal/autodie/eval space.
+
+ next if $package->isa('Fatal');
+ next if $package->isa($class);
+ next if $package->isa(__PACKAGE__);
+ next if $file =~ /^\(eval\s\d+\)$/;
+
+ last;
+
+ }
+
+ # We now have everything correct, *except* for our subroutine
+ # name. If it's __ANON__ or (eval), then we need to keep on
+ # digging deeper into our stack to find the real name. However we
+ # don't update our other information, since that will be correct
+ # for our current exception.
+
+ my $first_guess_subroutine = $sub;
+
+ while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
+ $depth++;
+
+ $sub = (CORE::caller($depth))[3];
+ }
+
+ # If we end up falling out the bottom of our stack, then our
+ # __ANON__ guess is the best we can get. This includes situations
+ # where we were called from the top level of a program.
+
+ if (not defined $sub) {
+ $sub = $first_guess_subroutine;
+ }
+
+ $this->{$PACKAGE}{package} = $package;
+ $this->{$PACKAGE}{file} = $file;
+ $this->{$PACKAGE}{line} = $line;
+ $this->{$PACKAGE}{caller} = $sub;
+ $this->{$PACKAGE}{package} = $package;
+
+ $this->{$PACKAGE}{errno} = $args{errno} || 0;
+
+ $this->{$PACKAGE}{context} = $args{context};
+ $this->{$PACKAGE}{return} = $args{return};
+ $this->{$PACKAGE}{eval_error} = $args{eval_error};
+
+ $this->{$PACKAGE}{args} = $args{args} || [];
+ $this->{$PACKAGE}{function}= $args{function} or
+ croak("$class->new() called without function arg");
+
+ return $this;
+
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<autodie>, L<autodie::exception::system>
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software. You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/Master/tlpkg/tlperl/lib/autodie/exception/system.pm b/Master/tlpkg/tlperl/lib/autodie/exception/system.pm
new file mode 100644
index 00000000000..07cd1c9a038
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/exception/system.pm
@@ -0,0 +1,81 @@
+package autodie::exception::system;
+use 5.008;
+use strict;
+use warnings;
+use base 'autodie::exception';
+use Carp qw(croak);
+
+our $VERSION = '2.06_01';
+
+my $PACKAGE = __PACKAGE__;
+
+=head1 NAME
+
+autodie::exception::system - Exceptions from autodying system().
+
+=head1 SYNOPSIS
+
+ eval {
+ use autodie qw(system);
+
+ system($cmd, @args);
+
+ };
+
+ if (my $E = $@) {
+ say "Ooops! ",$E->caller," had problems: $@";
+ }
+
+
+=head1 DESCRIPTION
+
+This is a L<autodie::exception> class for failures from the
+C<system> command.
+
+Presently there is no way to interrogate an C<autodie::exception::system>
+object for the command, exit status, and other information you'd expect
+such an object to hold. The interface will be expanded to accommodate
+this in the future.
+
+=cut
+
+sub _init {
+ my ($this, %args) = @_;
+
+ $this->{$PACKAGE}{message} = $args{message}
+ || croak "'message' arg not supplied to autodie::exception::system->new";
+
+ return $this->SUPER::_init(%args);
+
+}
+
+=head2 stringify
+
+When stringified, C<autodie::exception::system> objects currently
+use the message generated by L<IPC::System::Simple>.
+
+=cut
+
+sub stringify {
+
+ my ($this) = @_;
+
+ return $this->{$PACKAGE}{message} . $this->add_file_and_line;
+
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software. You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/Master/tlpkg/tlperl/lib/autodie/hints.pm b/Master/tlpkg/tlperl/lib/autodie/hints.pm
new file mode 100644
index 00000000000..e7be03a047a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie/hints.pm
@@ -0,0 +1,598 @@
+package autodie::hints;
+
+use strict;
+use warnings;
+
+use constant PERL58 => ( $] < 5.009 );
+
+our $VERSION = '2.06_01';
+
+=head1 NAME
+
+autodie::hints - Provide hints about user subroutines to autodie
+
+=head1 SYNOPSIS
+
+ package Your::Module;
+
+ our %DOES = ( 'autodie::hints::provider' => 1 );
+
+ sub AUTODIE_HINTS {
+ return {
+ foo => { scalar => HINTS, list => SOME_HINTS },
+ bar => { scalar => HINTS, list => MORE_HINTS },
+ }
+ }
+
+ # Later, in your main program...
+
+ use Your::Module qw(foo bar);
+ use autodie qw(:default foo bar);
+
+ foo(); # succeeds or dies based on scalar hints
+
+ # Alternatively, hints can be set on subroutines we've
+ # imported.
+
+ use autodie::hints;
+ use Some::Module qw(think_positive);
+
+ BEGIN {
+ autodie::hints->set_hints_for(
+ \&think_positive,
+ {
+ fail => sub { $_[0] <= 0 }
+ }
+ )
+ }
+ use autodie qw(think_positive);
+
+ think_positive(...); # Returns positive or dies.
+
+
+=head1 DESCRIPTION
+
+=head2 Introduction
+
+The L<autodie> pragma is very smart when it comes to working with
+Perl's built-in functions. The behaviour for these functions are
+fixed, and C<autodie> knows exactly how they try to signal failure.
+
+But what about user-defined subroutines from modules? If you use
+C<autodie> on a user-defined subroutine then it assumes the following
+behaviour to demonstrate failure:
+
+=over
+
+=item *
+
+A false value, in scalar context
+
+=item *
+
+An empty list, in list context
+
+=item *
+
+A list containing a single undef, in list context
+
+=back
+
+All other return values (including the list of the single zero, and the
+list containing a single empty string) are considered successful. However,
+real-world code isn't always that easy. Perhaps the code you're working
+with returns a string containing the word "FAIL" upon failure, or a
+two element list containing C<(undef, "human error message")>. To make
+autodie work with these sorts of subroutines, we have
+the I<hinting interface>.
+
+The hinting interface allows I<hints> to be provided to C<autodie>
+on how it should detect failure from user-defined subroutines. While
+these I<can> be provided by the end-user of C<autodie>, they are ideally
+written into the module itself, or into a helper module or sub-class
+of C<autodie> itself.
+
+=head2 What are hints?
+
+A I<hint> is a subroutine or value that is checked against the
+return value of an autodying subroutine. If the match returns true,
+C<autodie> considers the subroutine to have failed.
+
+If the hint provided is a subroutine, then C<autodie> will pass
+the complete return value to that subroutine. If the hint is
+any other value, then C<autodie> will smart-match against the
+value provided. In Perl 5.8.x there is no smart-match operator, and as such
+only subroutine hints are supported in these versions.
+
+Hints can be provided for both scalar and list contexts. Note
+that an autodying subroutine will never see a void context, as
+C<autodie> always needs to capture the return value for examination.
+Autodying subroutines called in void context act as if they're called
+in a scalar context, but their return value is discarded after it
+has been checked.
+
+=head2 Example hints
+
+Hints may consist of scalars, array references, regular expressions and
+subroutine references. You can specify different hints for how
+failure should be identified in scalar and list contexts.
+
+These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
+calling C<autodie::hints->set_hints_for()>.
+
+The most common context-specific hints are:
+
+ # Scalar failures always return undef:
+ { scalar => undef }
+
+ # Scalar failures return any false value [default expectation]:
+ { scalar => sub { ! $_[0] } }
+
+ # Scalar failures always return zero explicitly:
+ { scalar => '0' }
+
+ # List failures always return an empty list:
+ { list => [] }
+
+ # List failures return () or (undef) [default expectation]:
+ { list => sub { ! @_ || @_ == 1 && !defined $_[0] } }
+
+ # List failures return () or a single false value:
+ { list => sub { ! @_ || @_ == 1 && !$_[0] } }
+
+ # List failures return (undef, "some string")
+ { list => sub { @_ == 2 && !defined $_[0] } }
+
+ # Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
+ # returns (-1) in list context...
+ autodie::hints->set_hints_for(
+ \&foo,
+ {
+ scalar => qr/^ _? FAIL $/xms,
+ list => [-1],
+ }
+ );
+
+ # Unsuccessful foo() returns 0 in all contexts...
+ autodie::hints->set_hints_for(
+ \&foo,
+ {
+ scalar => 0,
+ list => [0],
+ }
+ );
+
+This "in all contexts" construction is very common, and can be
+abbreviated, using the 'fail' key. This sets both the C<scalar>
+and C<list> hints to the same value:
+
+ # Unsuccessful foo() returns 0 in all contexts...
+ autodie::hints->set_hints_for(
+ \&foo,
+ {
+ fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
+ }
+ );
+
+ # Unsuccessful think_positive() returns negative number on failure...
+ autodie::hints->set_hints_for(
+ \&think_positive,
+ {
+ fail => sub { $_[0] < 0 }
+ }
+ );
+
+ # Unsuccessful my_system() returns non-zero on failure...
+ autodie::hints->set_hints_for(
+ \&my_system,
+ {
+ fail => sub { $_[0] != 0 }
+ }
+ );
+
+=head1 Manually setting hints from within your program
+
+If you are using a module which returns something special on failure, then
+you can manually create hints for each of the desired subroutines. Once
+the hints are specified, they are available for all files and modules loaded
+thereafter, thus you can move this work into a module and it will still
+work.
+
+ use Some::Module qw(foo bar);
+ use autodie::hints;
+
+ autodie::hints->set_hints_for(
+ \&foo,
+ {
+ scalar => SCALAR_HINT,
+ list => LIST_HINT,
+ }
+ );
+ autodie::hints->set_hints_for(
+ \&bar,
+ { fail => SOME_HINT, }
+ );
+
+It is possible to pass either a subroutine reference (recommended) or a fully
+qualified subroutine name as the first argument. This means you can set hints
+on modules that I<might> get loaded:
+
+ use autodie::hints;
+ autodie::hints->set_hints_for(
+ 'Some::Module:bar', { fail => SCALAR_HINT, }
+ );
+
+This technique is most useful when you have a project that uses a
+lot of third-party modules. You can define all your possible hints
+in one-place. This can even be in a sub-class of autodie. For
+example:
+
+ package my::autodie;
+
+ use parent qw(autodie);
+ use autodie::hints;
+
+ autodie::hints->set_hints_for(...);
+
+ 1;
+
+You can now C<use my::autodie>, which will work just like the standard
+C<autodie>, but is now aware of any hints that you've set.
+
+=head1 Adding hints to your module
+
+C<autodie> provides a passive interface to allow you to declare hints for
+your module. These hints will be found and used by C<autodie> if it
+is loaded, but otherwise have no effect (or dependencies) without autodie.
+To set these, your module needs to declare that it I<does> the
+C<autodie::hints::provider> role. This can be done by writing your
+own C<DOES> method, using a system such as C<Class::DOES> to handle
+the heavy-lifting for you, or declaring a C<%DOES> package variable
+with a C<autodie::hints::provider> key and a corresponding true value.
+
+Note that checking for a C<%DOES> hash is an C<autodie>-only
+short-cut. Other modules do not use this mechanism for checking
+roles, although you can use the C<Class::DOES> module from the
+CPAN to allow it.
+
+In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
+a hash-reference containing the hints for your subroutines:
+
+ package Your::Module;
+
+ # We can use the Class::DOES from the CPAN to declare adherence
+ # to a role.
+
+ use Class::DOES 'autodie::hints::provider' => 1;
+
+ # Alternatively, we can declare the role in %DOES. Note that
+ # this is an autodie specific optimisation, although Class::DOES
+ # can be used to promote this to a true role declaration.
+
+ our %DOES = ( 'autodie::hints::provider' => 1 );
+
+ # Finally, we must define the hints themselves.
+
+ sub AUTODIE_HINTS {
+ return {
+ foo => { scalar => HINTS, list => SOME_HINTS },
+ bar => { scalar => HINTS, list => MORE_HINTS },
+ baz => { fail => HINTS },
+ }
+ }
+
+This allows your code to set hints without relying on C<autodie> and
+C<autodie::hints> being loaded, or even installed. In this way your
+code can do the right thing when C<autodie> is installed, but does not
+need to depend upon it to function.
+
+=head1 Insisting on hints
+
+When a user-defined subroutine is wrapped by C<autodie>, it will
+use hints if they are available, and otherwise reverts to the
+I<default behaviour> described in the introduction of this document.
+This can be problematic if we expect a hint to exist, but (for
+whatever reason) it has not been loaded.
+
+We can ask autodie to I<insist> that a hint be used by prefixing
+an exclamation mark to the start of the subroutine name. A lone
+exclamation mark indicates that I<all> subroutines after it must
+have hints declared.
+
+ # foo() and bar() must have their hints defined
+ use autodie qw( !foo !bar baz );
+
+ # Everything must have hints (recommended).
+ use autodie qw( ! foo bar baz );
+
+ # bar() and baz() must have their hints defined
+ use autodie qw( foo ! bar baz );
+
+ # Enable autodie for all of Perl's supported built-ins,
+ # as well as for foo(), bar() and baz(). Everything must
+ # have hints.
+ use autodie qw( ! :all foo bar baz );
+
+If hints are not available for the specified subroutines, this will cause a
+compile-time error. Insisting on hints for Perl's built-in functions
+(eg, C<open> and C<close>) is always successful.
+
+Insisting on hints is I<strongly> recommended.
+
+=cut
+
+# TODO: implement regular expression hints
+
+use constant UNDEF_ONLY => sub { not defined $_[0] };
+use constant EMPTY_OR_UNDEF => sub {
+ ! @_ or
+ @_==1 && !defined $_[0]
+};
+
+use constant EMPTY_ONLY => sub { @_ == 0 };
+use constant EMPTY_OR_FALSE => sub {
+ ! @_ or
+ @_==1 && !$_[0]
+};
+
+use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] };
+
+use constant DEFAULT_HINTS => {
+ scalar => UNDEF_ONLY,
+ list => EMPTY_OR_UNDEF,
+};
+
+
+use constant HINTS_PROVIDER => 'autodie::hints::provider';
+
+use base qw(Exporter);
+
+our $DEBUG = 0;
+
+# Only ( undef ) is a strange but possible situation for very
+# badly written code. It's not supported yet.
+
+my %Hints = (
+ 'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+ 'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+ 'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+ 'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
+);
+
+# Start by using Sub::Identify if it exists on this system.
+
+eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
+
+# If it doesn't exist, we'll define our own. This code is directly
+# taken from Rafael Garcia's Sub::Identify 0.04, used under the same
+# license as Perl itself.
+
+if ($@) {
+ require B;
+
+ no warnings 'once';
+
+ *get_code_info = sub ($) {
+
+ my ($coderef) = @_;
+ ref $coderef or return;
+ my $cv = B::svref_2object($coderef);
+ $cv->isa('B::CV') or return;
+ # bail out if GV is undefined
+ $cv->GV->isa('B::SPECIAL') and return;
+
+ return ($cv->GV->STASH->NAME, $cv->GV->NAME);
+ };
+
+}
+
+sub sub_fullname {
+ return join( '::', get_code_info( $_[1] ) );
+}
+
+my %Hints_loaded = ();
+
+sub load_hints {
+ my ($class, $sub) = @_;
+
+ my ($package) = ( $sub =~ /(.*)::/ );
+
+ if (not defined $package) {
+ require Carp;
+ Carp::croak(
+ "Internal error in autodie::hints::load_hints - no package found.
+ ");
+ }
+
+ # Do nothing if we've already tried to load hints for
+ # this package.
+ return if $Hints_loaded{$package}++;
+
+ my $hints_available = 0;
+
+ {
+ no strict 'refs'; ## no critic
+
+ if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
+ $hints_available = 1;
+ }
+ elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) {
+ $hints_available = 1;
+ }
+ elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
+ $hints_available = 1;
+ }
+ }
+
+ return if not $hints_available;
+
+ my %package_hints = %{ $package->AUTODIE_HINTS };
+
+ foreach my $sub (keys %package_hints) {
+
+ my $hint = $package_hints{$sub};
+
+ # Ensure we have a package name.
+ $sub = "${package}::$sub" if $sub !~ /::/;
+
+ # TODO - Currently we don't check for conflicts, should we?
+ $Hints{$sub} = $hint;
+
+ $class->normalise_hints(\%Hints, $sub);
+ }
+
+ return;
+
+}
+
+sub normalise_hints {
+ my ($class, $hints, $sub) = @_;
+
+ if ( exists $hints->{$sub}->{fail} ) {
+
+ if ( exists $hints->{$sub}->{scalar} or
+ exists $hints->{$sub}->{list}
+ ) {
+ # TODO: Turn into a proper diagnostic.
+ require Carp;
+ local $Carp::CarpLevel = 1;
+ Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
+ }
+
+ # Set our scalar and list hints.
+
+ $hints->{$sub}->{scalar} =
+ $hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
+
+ return;
+
+ }
+
+ # Check to make sure all our hints exist.
+
+ foreach my $hint (qw(scalar list)) {
+ if ( not exists $hints->{$sub}->{$hint} ) {
+ # TODO: Turn into a proper diagnostic.
+ require Carp;
+ local $Carp::CarpLevel = 1;
+ Carp::croak("$hint hint missing for $sub");
+ }
+ }
+
+ return;
+}
+
+sub get_hints_for {
+ my ($class, $sub) = @_;
+
+ my $subname = $class->sub_fullname( $sub );
+
+ # If we have hints loaded for a sub, then return them.
+
+ if ( exists $Hints{ $subname } ) {
+ return $Hints{ $subname };
+ }
+
+ # If not, we try to load them...
+
+ $class->load_hints( $subname );
+
+ # ...and try again!
+
+ if ( exists $Hints{ $subname } ) {
+ return $Hints{ $subname };
+ }
+
+ # It's the caller's responsibility to use defaults if desired.
+ # This allows on autodie to insist on hints if needed.
+
+ return;
+
+}
+
+sub set_hints_for {
+ my ($class, $sub, $hints) = @_;
+
+ if (ref $sub) {
+ $sub = $class->sub_fullname( $sub );
+
+ require Carp;
+
+ $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
+ }
+
+ if ($DEBUG) {
+ warn "autodie::hints: Setting $sub to hints: $hints\n";
+ }
+
+ $Hints{ $sub } = $hints;
+
+ $class->normalise_hints(\%Hints, $sub);
+
+ return;
+}
+
+1;
+
+__END__
+
+
+=head1 Diagnostics
+
+=over 4
+
+=item Attempts to set_hints_for unidentifiable subroutine
+
+You've called C<< autodie::hints->set_hints_for() >> using a subroutine
+reference, but that reference could not be resolved back to a
+subroutine name. It may be an anonymous subroutine (which can't
+be made autodying), or may lack a name for other reasons.
+
+If you receive this error with a subroutine that has a real name,
+then you may have found a bug in autodie. See L<autodie/BUGS>
+for how to report this.
+
+=item fail hints cannot be provided with either scalar or list hints for %s
+
+When defining hints, you can either supply both C<list> and
+C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
+You can't mix and match them.
+
+=item %s hint missing for %s
+
+You've provided either a C<scalar> hint without supplying
+a C<list> hint, or vice-versa. You I<must> supply both C<scalar>
+and C<list> hints, I<or> a single C<fail> hint.
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+=over
+
+=item *
+
+Dr Damian Conway for suggesting the hinting interface and providing the
+example usage.
+
+=item *
+
+Jacinta Richardson for translating much of my ideas into this
+documentation.
+
+=back
+
+=head1 AUTHOR
+
+Copyright 2009, Paul Fenwick E<lt>pjf@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<autodie>, L<Class::DOES>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/encoding/warnings.pm b/Master/tlpkg/tlperl/lib/encoding/warnings.pm
new file mode 100644
index 00000000000..5e6aec0c8fe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/encoding/warnings.pm
@@ -0,0 +1,239 @@
+package encoding::warnings;
+$encoding::warnings::VERSION = '0.11';
+
+use strict;
+use 5.007;
+
+=head1 NAME
+
+encoding::warnings - Warn on implicit encoding conversions
+
+=head1 VERSION
+
+This document describes version 0.11 of encoding::warnings, released
+June 5, 2007.
+
+=head1 SYNOPSIS
+
+ use encoding::warnings; # or 'FATAL' to raise fatal exceptions
+
+ utf8::encode($a = chr(20000)); # a byte-string (raw bytes)
+ $b = chr(20000); # a unicode-string (wide characters)
+
+ # "Bytes implicitly upgraded into wide characters as iso-8859-1"
+ $c = $a . $b;
+
+=head1 DESCRIPTION
+
+=head2 Overview of the problem
+
+By default, there is a fundamental asymmetry in Perl's unicode model:
+implicit upgrading from byte-strings to unicode-strings assumes that
+they were encoded in I<ISO 8859-1 (Latin-1)>, but unicode-strings are
+downgraded with UTF-8 encoding. This happens because the first 256
+codepoints in Unicode happens to agree with Latin-1.
+
+However, this silent upgrading can easily cause problems, if you happen
+to mix unicode strings with non-Latin1 data -- i.e. byte-strings encoded
+in UTF-8 or other encodings. The error will not manifest until the
+combined string is written to output, at which time it would be impossible
+to see where did the silent upgrading occur.
+
+=head2 Detecting the problem
+
+This module simplifies the process of diagnosing such problems. Just put
+this line on top of your main program:
+
+ use encoding::warnings;
+
+Afterwards, implicit upgrading of high-bit bytes will raise a warning.
+Ex.: C<Bytes implicitly upgraded into wide characters as iso-8859-1 at
+- line 7>.
+
+However, strings composed purely of ASCII code points (C<0x00>..C<0x7F>)
+will I<not> trigger this warning.
+
+You can also make the warnings fatal by importing this module as:
+
+ use encoding::warnings 'FATAL';
+
+=head2 Solving the problem
+
+Most of the time, this warning occurs when a byte-string is concatenated
+with a unicode-string. There are a number of ways to solve it:
+
+=over 4
+
+=item * Upgrade both sides to unicode-strings
+
+If your program does not need compatibility for Perl 5.6 and earlier,
+the recommended approach is to apply appropriate IO disciplines, so all
+data in your program become unicode-strings. See L<encoding>, L<open> and
+L<perlfunc/binmode> for how.
+
+=item * Downgrade both sides to byte-strings
+
+The other way works too, especially if you are sure that all your data
+are under the same encoding, or if compatibility with older versions
+of Perl is desired.
+
+You may downgrade strings with C<Encode::encode> and C<utf8::encode>.
+See L<Encode> and L<utf8> for details.
+
+=item * Specify the encoding for implicit byte-string upgrading
+
+If you are confident that all byte-strings will be in a specific
+encoding like UTF-8, I<and> need not support older versions of Perl,
+use the C<encoding> pragma:
+
+ use encoding 'utf8';
+
+Similarly, this will silence warnings from this module, and preserve the
+default behaviour:
+
+ use encoding 'iso-8859-1';
+
+However, note that C<use encoding> actually had three distinct effects:
+
+=over 4
+
+=item * PerlIO layers for B<STDIN> and B<STDOUT>
+
+This is similar to what L<open> pragma does.
+
+=item * Literal conversions
+
+This turns I<all> literal string in your program into unicode-strings
+(equivalent to a C<use utf8>), by decoding them using the specified
+encoding.
+
+=item * Implicit upgrading for byte-strings
+
+This will silence warnings from this module, as shown above.
+
+=back
+
+Because literal conversions also work on empty strings, it may surprise
+some people:
+
+ use encoding 'big5';
+
+ my $byte_string = pack("C*", 0xA4, 0x40);
+ print length $a; # 2 here.
+ $a .= ""; # concatenating with a unicode string...
+ print length $a; # 1 here!
+
+In other words, do not C<use encoding> unless you are certain that the
+program will not deal with any raw, 8-bit binary data at all.
+
+However, the C<Filter =E<gt> 1> flavor of C<use encoding> will I<not>
+affect implicit upgrading for byte-strings, and is thus incapable of
+silencing warnings from this module. See L<encoding> for more details.
+
+=back
+
+=head1 CAVEATS
+
+For Perl 5.9.4 or later, this module's effect is lexical.
+
+For Perl versions prior to 5.9.4, this module affects the whole script,
+instead of inside its lexical block.
+
+=cut
+
+# Constants.
+sub ASCII () { 0 }
+sub LATIN1 () { 1 }
+sub FATAL () { 2 }
+
+# Install a ${^ENCODING} handler if no other one are already in place.
+sub import {
+ my $class = shift;
+ my $fatal = shift || '';
+
+ local $@;
+ return if ${^ENCODING} and ref(${^ENCODING}) ne $class;
+ return unless eval { require Encode; 1 };
+
+ my $ascii = Encode::find_encoding('us-ascii') or return;
+ my $latin1 = Encode::find_encoding('iso-8859-1') or return;
+
+ # Have to undef explicitly here
+ undef ${^ENCODING};
+
+ # Install a warning handler for decode()
+ my $decoder = bless(
+ [
+ $ascii,
+ $latin1,
+ (($fatal eq 'FATAL') ? 'Carp::croak' : 'Carp::carp'),
+ ], $class,
+ );
+
+ ${^ENCODING} = $decoder;
+ $^H{$class} = 1;
+}
+
+sub unimport {
+ my $class = shift;
+ $^H{$class} = undef;
+ undef ${^ENCODING};
+}
+
+# Don't worry about source code literals.
+sub cat_decode {
+ my $self = shift;
+ return $self->[LATIN1]->cat_decode(@_);
+}
+
+# Warn if the data is not purely US-ASCII.
+sub decode {
+ my $self = shift;
+
+ DO_WARN: {
+ if ($] >= 5.009004) {
+ my $hints = (caller(0))[10];
+ $hints->{ref($self)} or last DO_WARN;
+ }
+
+ local $@;
+ my $rv = eval { $self->[ASCII]->decode($_[0], Encode::FB_CROAK()) };
+ return $rv unless $@;
+
+ require Carp;
+ no strict 'refs';
+ $self->[FATAL]->(
+ "Bytes implicitly upgraded into wide characters as iso-8859-1"
+ );
+
+ }
+
+ return $self->[LATIN1]->decode(@_);
+}
+
+sub name { 'iso-8859-1' }
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<perlunicode>, L<perluniintro>
+
+L<open>, L<utf8>, L<encoding>, L<Encode>
+
+=head1 AUTHORS
+
+Audrey Tang
+
+=head1 COPYRIGHT
+
+Copyright 2004, 2005, 2006, 2007 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+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
diff --git a/Master/tlpkg/tlperl/lib/inc/latest.pm b/Master/tlpkg/tlperl/lib/inc/latest.pm
new file mode 100644
index 00000000000..fc9e2e94bf8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/inc/latest.pm
@@ -0,0 +1,246 @@
+package inc::latest;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.3603';
+$VERSION = eval $VERSION;
+
+use Carp;
+use File::Basename ();
+use File::Spec ();
+use File::Path ();
+use IO::File ();
+use File::Copy ();
+
+# track and return modules loaded by inc::latest
+my @loaded_modules;
+sub loaded_modules {@loaded_modules}
+
+# must ultimately "goto" the import routine of the module to be loaded
+# so that the calling package is correct when $mod->import() runs.
+sub import {
+ my ($package, $mod, @args) = @_;
+ return unless(defined $mod);
+
+ my $private_path = 'inc/latest/private.pm';
+ if(-e $private_path) {
+ # user mode - delegate work to bundled private module
+ require $private_path;
+ splice( @_, 0, 1, 'inc::latest::private');
+ goto \&inc::latest::private::import;
+ }
+
+ # author mode - just record and load the modules
+ push(@loaded_modules, $mod);
+ require inc::latest::private;
+ goto \&inc::latest::private::_load_module;
+}
+
+sub write {
+ my $package = shift;
+ my ($where, @preload) = @_;
+
+ warn "should really be writing in inc/" unless $where =~ /inc$/;
+
+ # write inc/latest.pm
+ File::Path::mkpath( $where );
+ my $fh = IO::File->new( File::Spec->catfile($where,'latest.pm'), "w" );
+ print {$fh} "# This stub created by inc::latest $VERSION\n";
+ print {$fh} <<'HERE';
+package inc::latest;
+use strict;
+use vars '@ISA';
+require inc::latest::private;
+@ISA = qw/inc::latest::private/;
+HERE
+ if (@preload) {
+ print {$fh} "\npackage inc::latest::preload;\n";
+ for my $mod (@preload) {
+ print {$fh} "inc::latest->import('$mod');\n";
+ }
+ }
+ print {$fh} "\n1;\n";
+ close $fh;
+
+ # write inc/latest/private;
+ require inc::latest::private;
+ File::Path::mkpath( File::Spec->catdir( $where, 'latest' ) );
+ my $from = $INC{'inc/latest/private.pm'};
+ my $to = File::Spec->catfile($where,'latest','private.pm');
+ File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
+
+ return 1;
+}
+
+sub bundle_module {
+ my ($package, $module, $where) = @_;
+
+ # create inc/inc_$foo
+ (my $dist = $module) =~ s{::}{-}g;
+ my $inc_lib = File::Spec->catdir($where,"inc_$dist");
+ File::Path::mkpath $inc_lib;
+
+ # get list of files to copy
+ require ExtUtils::Installed;
+ # workaround buggy EU::Installed check of @INC
+ my $inst = ExtUtils::Installed->new(extra_libs => [@INC]);
+ my $packlist = $inst->packlist( $module ) or die "Couldn't find packlist";
+ my @files = grep { /\.pm$/ } keys %$packlist;
+
+
+ # figure out prefix
+ my $mod_path = quotemeta $package->_mod2path( $module );
+ my ($prefix) = grep { /$mod_path$/ } @files;
+ $prefix =~ s{$mod_path$}{};
+
+ # copy files
+ for my $from ( @files ) {
+ next unless $from =~ /\.pm$/;
+ (my $mod_path = $from) =~ s{^\Q$prefix\E}{};
+ my $to = File::Spec->catfile( $inc_lib, $mod_path );
+ File::Path::mkpath(File::Basename::dirname($to));
+ File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
+ }
+ return 1;
+}
+
+# Translate a module name into a directory/file.pm to search for in @INC
+sub _mod2path {
+ my ($self, $mod) = @_;
+ my @parts = split /::/, $mod;
+ $parts[-1] .= '.pm';
+ return $parts[0] if @parts == 1;
+ return File::Spec->catfile(@parts);
+}
+
+1;
+
+
+=head1 NAME
+
+inc::latest - use modules bundled in inc/ if they are newer than installed ones
+
+=head1 SYNOPSIS
+
+ # in Build.PL
+ use inc::latest 'Module::Build';
+
+=head1 DESCRIPTION
+
+The C<inc::latest> module helps bootstrap configure-time dependencies for CPAN
+distributions. These dependencies get bundled into the C<inc> directory within
+a distribution and are used by Build.PL (or Makefile.PL).
+
+Arguments to C<inc::latest> are module names that are checked against both the
+current C<@INC> array and against specially-named directories in C<inc>. If
+the bundled verison is newer than the installed one (or the module isn't
+installed, then, the bundled directory is added to the start of <@INC> and the
+module is loaded from there.
+
+There are actually two variations of C<inc::latest> -- one for authors and one
+for the C<inc> directory. For distribution authors, the C<inc::latest>
+installed in the system will record modules loaded via C<inc::latest> and can
+be used to create the bundled files in C<inc>, including writing the second
+variation as C<inc/latest.pm>.
+
+This second C<inc::latest> is the one that is loaded in a distribution being
+installed (e.g. from Build.PL). This bundled C<inc::latest> is the one
+that determines which module to load.
+
+=head2 Special notes on bundling
+
+The C<inc::latest> module creates bundled directories based on the packlist
+file of an installed distribution. Even though C<inc::latest> takes module
+name arguments, it is better to think of it as bundling and making available
+entire I<distributions>. When a module is loaded through C<inc::latest>,
+it looks in all bundled distributions in C<inc/> for a newer module than
+can be found in the existing C<@INC> array.
+
+Thus, the module-name provided should usually be the "top-level" module name of
+a distribution, though this is not strictly required. For example,
+L<Module::Build> has a number of heuristics to map module names to packlists,
+allowing users to do things like this:
+
+ use inc::latest 'Devel::AssertOS::Unix';
+
+even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
+distribution.
+
+At the current time, packlists are required. Thus, bundling dual-core modules
+may require a 'forced install' over versions in the latest version of perl
+in order to create the necessary packlist for bundling.
+
+=head1 USAGE
+
+When calling C<use>, the bundled C<inc::latest> takes a single module name and
+optional arguments to pass to that module's own import method.
+
+ use 'inc::latest' 'Foo::Bar' qw/foo bar baz/;
+
+=head2 Author-mode
+
+You are in author-mode inc::latest if any of the Author-mode methods are
+available. For example:
+
+ if ( inc::latest->can('write') ) {
+ inc::latest->write('inc');
+ }
+
+=over 4
+
+=item loaded_modules()
+
+ my @list = inc::latest->loaded_modules;
+
+This takes no arguments and always returns a list of module names requested for
+loading via "use inc::latest 'MODULE'", regardless of wether the load was
+successful or not.
+
+=item write()
+
+ inc::latest->write( 'inc' );
+
+This writes the bundled version of inc::latest to the directory name given as an
+argument. It almost all cases, it should be 'C<inc>'.
+
+=item bundle_module()
+
+ for my $mod ( inc::latest->loaded_modules ) {
+ inc::latest->bundle_module($mod, $dir);
+ }
+
+If $mod corresponds to a packlist, then this function creates a specially-named
+directory in $dir and copies all .pm files from the modlist to the new
+directory (which almost always should just be 'inc'). For example, if Foo::Bar
+is the name of the module, and $dir is 'inc', then the directory would be
+'inc/inc_Foo-Bar' and contain files like this:
+
+ inc/inc_Foo-Bar/Foo/Bar.pm
+
+Currently, $mod B<must> have a packlist. If this is not the case (e.g. for a
+dual-core module), then the bundling will fail. You may be able to create a
+packlist by forced installing the module on top of the version that came with
+core Perl.
+
+=back
+
+=head2 As bundled in inc/
+
+All methods are private. Only the C<import> method is public.
+
+=head1 AUTHOR
+
+Eric Wilhelm <ewilhelm@cpan.org>, David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2009 by Eric Wilhelm and David Golden
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Module::Build>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/inc/latest/private.pm b/Master/tlpkg/tlperl/lib/inc/latest/private.pm
new file mode 100644
index 00000000000..572ae8a82cb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/inc/latest/private.pm
@@ -0,0 +1,101 @@
+package inc::latest::private;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.3603';
+$VERSION = eval $VERSION;
+
+use File::Spec;
+use IO::File;
+
+# must ultimately "goto" the import routine of the module to be loaded
+# so that the calling package is correct when $mod->import() runs.
+sub import {
+ my ($package, $mod, @args) = @_;
+ my $file = $package->_mod2path($mod);
+
+ if ($INC{$file}) {
+ # Already loaded, but let _load_module handle import args
+ goto \&_load_module;
+ }
+
+ # A bundled copy must be present
+ my ($bundled, $bundled_dir) = $package->_search_bundled($file)
+ or die "No bundled copy of $mod found";
+
+ my $from_inc = $package->_search_INC($file);
+ unless ($from_inc) {
+ # Only bundled is available
+ unshift(@INC, $bundled_dir);
+ goto \&_load_module;
+ }
+
+ if (_version($from_inc) >= _version($bundled)) {
+ # Ignore the bundled copy
+ goto \&_load_module;
+ }
+
+ # Load the bundled copy
+ unshift(@INC, $bundled_dir);
+ goto \&_load_module;
+}
+
+sub _version {
+ require ExtUtils::MakeMaker;
+ return ExtUtils::MM->parse_version(shift);
+}
+
+# use "goto" for import to preserve caller
+sub _load_module {
+ my $package = shift; # remaining @_ is ready for goto
+ my ($mod, @args) = @_;
+ eval "require $mod; 1" or die $@;
+ if ( my $import = $mod->can('import') ) {
+ goto $import;
+ }
+ return 1;
+}
+
+sub _search_bundled {
+ my ($self, $file) = @_;
+
+ my $mypath = 'inc';
+
+ local *DH; # Maintain 5.005 compatibility
+ opendir DH, $mypath or die "Can't open directory $mypath: $!";
+
+ while (defined(my $e = readdir DH)) {
+ next unless $e =~ /^inc_/;
+ my $try = File::Spec->catfile($mypath, $e, $file);
+
+ return($try, File::Spec->catdir($mypath, $e)) if -e $try;
+ }
+ return;
+}
+
+# Look for the given path in @INC.
+sub _search_INC {
+ # TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but
+ # it probably should
+ my ($self, $file) = @_;
+
+ foreach my $dir (@INC) {
+ next if ref $dir;
+ my $try = File::Spec->catfile($dir, $file);
+ return $try if -e $try;
+ }
+
+ return;
+}
+
+# Translate a module name into a directory/file.pm to search for in @INC
+sub _mod2path {
+ my ($self, $mod) = @_;
+ my @parts = split /::/, $mod;
+ $parts[-1] .= '.pm';
+ return $parts[0] if @parts == 1;
+ return File::Spec->catfile(@parts);
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/overload/numbers.pm b/Master/tlpkg/tlperl/lib/overload/numbers.pm
new file mode 100644
index 00000000000..d9daab58a63
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/overload/numbers.pm
@@ -0,0 +1,163 @@
+# -*- buffer-read-only: t -*-
+#
+# lib/overload/numbers.pm
+#
+# Copyright (C) 2008 by Larry Wall and others
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by overload.pl
+#
+
+package overload::numbers;
+
+our @names = qw#
+ ()
+ (${}
+ (@{}
+ (%{}
+ (*{}
+ (&{}
+ (++
+ (--
+ (bool
+ (0+
+ (""
+ (!
+ (=
+ (abs
+ (neg
+ (<>
+ (int
+ (<
+ (<=
+ (>
+ (>=
+ (==
+ (!=
+ (lt
+ (le
+ (gt
+ (ge
+ (eq
+ (ne
+ (nomethod
+ (+
+ (+=
+ (-
+ (-=
+ (*
+ (*=
+ (/
+ (/=
+ (%
+ (%=
+ (**
+ (**=
+ (<<
+ (<<=
+ (>>
+ (>>=
+ (&
+ (&=
+ (|
+ (|=
+ (^
+ (^=
+ (<=>
+ (cmp
+ (~
+ (atan2
+ (cos
+ (sin
+ (exp
+ (log
+ (sqrt
+ (x
+ (x=
+ (.
+ (.=
+ (~~
+ (-X
+ (qr
+ DESTROY
+#;
+
+our @enums = qw#
+ fallback
+ to_sv
+ to_av
+ to_hv
+ to_gv
+ to_cv
+ inc
+ dec
+ bool_
+ numer
+ string
+ not
+ copy
+ abs
+ neg
+ iter
+ int
+ lt
+ le
+ gt
+ ge
+ eq
+ ne
+ slt
+ sle
+ sgt
+ sge
+ seq
+ sne
+ nomethod
+ add
+ add_ass
+ subtr
+ subtr_ass
+ mult
+ mult_ass
+ div
+ div_ass
+ modulo
+ modulo_ass
+ pow
+ pow_ass
+ lshift
+ lshift_ass
+ rshift
+ rshift_ass
+ band
+ band_ass
+ bor
+ bor_ass
+ bxor
+ bxor_ass
+ ncmp
+ scmp
+ compl
+ atan2
+ cos
+ sin
+ exp
+ log
+ sqrt
+ repeat
+ repeat_ass
+ concat
+ concat_ass
+ smart
+ ftest
+ regexp
+ DESTROY
+#;
+
+{ my $i = 0; our %names = map { $_ => $i++ } @names }
+
+{ my $i = 0; our %enums = map { $_ => $i++ } @enums }
+
diff --git a/Master/tlpkg/tlperl/lib/threads/shared.pm b/Master/tlpkg/tlperl/lib/threads/shared.pm
new file mode 100644
index 00000000000..72192bc7a0d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/threads/shared.pm
@@ -0,0 +1,616 @@
+package threads::shared;
+
+use 5.008;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw(reftype refaddr blessed);
+
+our $VERSION = '1.32';
+my $XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+# Declare that we have been loaded
+$threads::shared::threads_shared = 1;
+
+# Load the XS code, if applicable
+if ($threads::threads) {
+ require XSLoader;
+ XSLoader::load('threads::shared', $XS_VERSION);
+
+ *is_shared = \&_id;
+
+} else {
+ # String eval is generally evil, but we don't want these subs to
+ # exist at all if 'threads' is not loaded successfully.
+ # Vivifying them conditionally this way saves on average about 4K
+ # of memory per thread.
+ eval <<'_MARKER_';
+ sub share (\[$@%]) { return $_[0] }
+ sub is_shared (\[$@%]) { undef }
+ sub cond_wait (\[$@%];\[$@%]) { undef }
+ sub cond_timedwait (\[$@%]$;\[$@%]) { undef }
+ sub cond_signal (\[$@%]) { undef }
+ sub cond_broadcast (\[$@%]) { undef }
+_MARKER_
+}
+
+
+### Export ###
+
+sub import
+{
+ # Exported subroutines
+ my @EXPORT = qw(share is_shared cond_wait cond_timedwait
+ cond_signal cond_broadcast shared_clone);
+ if ($threads::threads) {
+ push(@EXPORT, 'bless');
+ }
+
+ # Export subroutine names
+ my $caller = caller();
+ foreach my $sym (@EXPORT) {
+ no strict 'refs';
+ *{$caller.'::'.$sym} = \&{$sym};
+ }
+}
+
+
+# Predeclarations for internal functions
+my ($make_shared);
+
+
+### Methods, etc. ###
+
+sub threads::shared::tie::SPLICE
+{
+ require Carp;
+ Carp::croak('Splice not implemented for shared arrays');
+}
+
+
+# Create a thread-shared clone of a complex data structure or object
+sub shared_clone
+{
+ if (@_ != 1) {
+ require Carp;
+ Carp::croak('Usage: shared_clone(REF)');
+ }
+
+ return $make_shared->(shift, {});
+}
+
+
+### Internal Functions ###
+
+# Used by shared_clone() to recursively clone
+# a complex data structure or object
+$make_shared = sub {
+ my ($item, $cloned) = @_;
+
+ # Just return the item if:
+ # 1. Not a ref;
+ # 2. Already shared; or
+ # 3. Not running 'threads'.
+ return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
+
+ # Check for previously cloned references
+ # (this takes care of circular refs as well)
+ my $addr = refaddr($item);
+ if (exists($cloned->{$addr})) {
+ # Return the already existing clone
+ return $cloned->{$addr};
+ }
+
+ # Make copies of array, hash and scalar refs and refs of refs
+ my $copy;
+ my $ref_type = reftype($item);
+
+ # Copy an array ref
+ if ($ref_type eq 'ARRAY') {
+ # Make empty shared array ref
+ $copy = &share([]);
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ push(@$copy, map { $make_shared->($_, $cloned) } @$item);
+ }
+
+ # Copy a hash ref
+ elsif ($ref_type eq 'HASH') {
+ # Make empty shared hash ref
+ $copy = &share({});
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ foreach my $key (keys(%{$item})) {
+ $copy->{$key} = $make_shared->($item->{$key}, $cloned);
+ }
+ }
+
+ # Copy a scalar ref
+ elsif ($ref_type eq 'SCALAR') {
+ $copy = \do{ my $scalar = $$item; };
+ share($copy);
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ }
+
+ # Copy of a ref of a ref
+ elsif ($ref_type eq 'REF') {
+ # Special handling for $x = \$x
+ if ($addr == refaddr($$item)) {
+ $copy = \$copy;
+ share($copy);
+ $cloned->{$addr} = $copy;
+ } else {
+ my $tmp;
+ $copy = \$tmp;
+ share($copy);
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ $tmp = $make_shared->($$item, $cloned);
+ }
+
+ } else {
+ require Carp;
+ Carp::croak("Unsupported ref type: ", $ref_type);
+ }
+
+ # If input item is an object, then bless the copy into the same class
+ if (my $class = blessed($item)) {
+ bless($copy, $class);
+ }
+
+ # Clone READONLY flag
+ if ($ref_type eq 'SCALAR') {
+ if (Internals::SvREADONLY($$item)) {
+ Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003);
+ }
+ }
+ if (Internals::SvREADONLY($item)) {
+ Internals::SvREADONLY($copy, 1) if ($] >= 5.008003);
+ }
+
+ return $copy;
+};
+
+1;
+
+__END__
+
+=head1 NAME
+
+threads::shared - Perl extension for sharing data structures between threads
+
+=head1 VERSION
+
+This document describes threads::shared version 1.32
+
+=head1 SYNOPSIS
+
+ use threads;
+ use threads::shared;
+
+ my $var :shared;
+ my %hsh :shared;
+ my @ary :shared;
+
+ my ($scalar, @array, %hash);
+ share($scalar);
+ share(@array);
+ share(%hash);
+
+ $var = $scalar_value;
+ $var = $shared_ref_value;
+ $var = shared_clone($non_shared_ref_value);
+ $var = shared_clone({'foo' => [qw/foo bar baz/]});
+
+ $hsh{'foo'} = $scalar_value;
+ $hsh{'bar'} = $shared_ref_value;
+ $hsh{'baz'} = shared_clone($non_shared_ref_value);
+ $hsh{'quz'} = shared_clone([1..3]);
+
+ $ary[0] = $scalar_value;
+ $ary[1] = $shared_ref_value;
+ $ary[2] = shared_clone($non_shared_ref_value);
+ $ary[3] = shared_clone([ {}, [] ]);
+
+ { lock(%hash); ... }
+
+ cond_wait($scalar);
+ cond_timedwait($scalar, time() + 30);
+ cond_broadcast(@array);
+ cond_signal(%hash);
+
+ my $lockvar :shared;
+ # condition var != lock var
+ cond_wait($var, $lockvar);
+ cond_timedwait($var, time()+30, $lockvar);
+
+=head1 DESCRIPTION
+
+By default, variables are private to each thread, and each newly created
+thread gets a private copy of each existing variable. This module allows you
+to share variables across different threads (and pseudo-forks on Win32). It
+is used together with the L<threads> module.
+
+This module supports the sharing of the following data types only: scalars
+and scalar refs, arrays and array refs, and hashes and hash refs.
+
+=head1 EXPORT
+
+The following functions are exported by this module: C<share>,
+C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
+and C<cond_broadcast>
+
+Note that if this module is imported when L<threads> has not yet been loaded,
+then these functions all become no-ops. This makes it possible to write
+modules that will work in both threaded and non-threaded environments.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item share VARIABLE
+
+C<share> takes a variable and marks it as shared:
+
+ my ($scalar, @array, %hash);
+ share($scalar);
+ share(@array);
+ share(%hash);
+
+C<share> will return the shared rvalue, but always as a reference.
+
+Variables can also be marked as shared at compile time by using the
+C<:shared> attribute:
+
+ my ($var, %hash, @array) :shared;
+
+Shared variables can only store scalars, refs of shared variables, or
+refs of shared data (discussed in next section):
+
+ my ($var, %hash, @array) :shared;
+ my $bork;
+
+ # Storing scalars
+ $var = 1;
+ $hash{'foo'} = 'bar';
+ $array[0] = 1.5;
+
+ # Storing shared refs
+ $var = \%hash;
+ $hash{'ary'} = \@array;
+ $array[1] = \$var;
+
+ # The following are errors:
+ # $var = \$bork; # ref of non-shared variable
+ # $hash{'bork'} = []; # non-shared array ref
+ # push(@array, { 'x' => 1 }); # non-shared hash ref
+
+=item shared_clone REF
+
+C<shared_clone> takes a reference, and returns a shared version of its
+argument, performing a deep copy on any non-shared elements. Any shared
+elements in the argument are used as is (i.e., they are not cloned).
+
+ my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
+
+Object status (i.e., the class an object is blessed into) is also cloned.
+
+ my $obj = {'foo' => [qw/foo bar baz/]};
+ bless($obj, 'Foo');
+ my $cpy = shared_clone($obj);
+ print(ref($cpy), "\n"); # Outputs 'Foo'
+
+For cloning empty array or hash refs, the following may also be used:
+
+ $var = &share([]); # Same as $var = shared_clone([]);
+ $var = &share({}); # Same as $var = shared_clone({});
+
+=item is_shared VARIABLE
+
+C<is_shared> checks if the specified variable is shared or not. If shared,
+returns the variable's internal ID (similar to
+L<refaddr()|Scalar::Util/"refaddr EXPR">). Otherwise, returns C<undef>.
+
+ if (is_shared($var)) {
+ print("\$var is shared\n");
+ } else {
+ print("\$var is not shared\n");
+ }
+
+When used on an element of an array or hash, C<is_shared> checks if the
+specified element belongs to a shared array or hash. (It does not check
+the contents of that element.)
+
+ my %hash :shared;
+ if (is_shared(%hash)) {
+ print("\%hash is shared\n");
+ }
+
+ $hash{'elem'} = 1;
+ if (is_shared($hash{'elem'})) {
+ print("\$hash{'elem'} is in a shared hash\n");
+ }
+
+=item lock VARIABLE
+
+C<lock> places a B<advisory> lock on a variable until the lock goes out of
+scope. If the variable is locked by another thread, the C<lock> call will
+block until it's available. Multiple calls to C<lock> by the same thread from
+within dynamically nested scopes are safe -- the variable will remain locked
+until the outermost lock on the variable goes out of scope.
+
+C<lock> follows references exactly I<one> level:
+
+ my %hash :shared;
+ my $ref = \%hash;
+ lock($ref); # This is equivalent to lock(%hash)
+
+Note that you cannot explicitly unlock a variable; you can only wait for the
+lock to go out of scope. This is most easily accomplished by locking the
+variable inside a block.
+
+ my $var :shared;
+ {
+ lock($var);
+ # $var is locked from here to the end of the block
+ ...
+ }
+ # $var is now unlocked
+
+As locks are advisory, they do not prevent data access or modification by
+another thread that does not itself attempt to obtain a lock on the variable.
+
+You cannot lock the individual elements of a container variable:
+
+ my %hash :shared;
+ $hash{'foo'} = 'bar';
+ #lock($hash{'foo'}); # Error
+ lock(%hash); # Works
+
+If you need more fine-grained control over shared variable access, see
+L<Thread::Semaphore>.
+
+=item cond_wait VARIABLE
+
+=item cond_wait CONDVAR, LOCKVAR
+
+The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks
+the variable, and blocks until another thread does a C<cond_signal> or
+C<cond_broadcast> for that same locked variable. The variable that
+C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. If
+there are multiple threads C<cond_wait>ing on the same variable, all but one
+will re-block waiting to reacquire the lock on the variable. (So if you're only
+using C<cond_wait> for synchronisation, give up the lock as soon as possible).
+The two actions of unlocking the variable and entering the blocked wait state
+are atomic, the two actions of exiting from the blocked wait state and
+re-locking the variable are not.
+
+In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed
+by a shared, B<locked> variable. The second variable is unlocked and thread
+execution suspended until another thread signals the first variable.
+
+It is important to note that the variable can be notified even if no thread
+C<cond_signal> or C<cond_broadcast> on the variable. It is therefore
+important to check the value of the variable and go back to waiting if the
+requirement is not fulfilled. For example, to pause until a shared counter
+drops to zero:
+
+ { lock($counter); cond_wait($counter) until $counter == 0; }
+
+=item cond_timedwait VARIABLE, ABS_TIMEOUT
+
+=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR
+
+In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an
+absolute timeout as parameters, unlocks the variable, and blocks until the
+timeout is reached or another thread signals the variable. A false value is
+returned if the timeout is reached, and a true value otherwise. In either
+case, the variable is re-locked upon return.
+
+Like C<cond_wait>, this function may take a shared, B<locked> variable as an
+additional parameter; in this case the first parameter is an B<unlocked>
+condition variable protected by a distinct lock variable.
+
+Again like C<cond_wait>, waking up and reacquiring the lock are not atomic,
+and you should always check your desired condition after this function
+returns. Since the timeout is an absolute value, however, it does not have to
+be recalculated with each pass:
+
+ lock($var);
+ my $abs = time() + 15;
+ until ($ok = desired_condition($var)) {
+ last if !cond_timedwait($var, $abs);
+ }
+ # we got it if $ok, otherwise we timed out!
+
+=item cond_signal VARIABLE
+
+The C<cond_signal> function takes a B<locked> variable as a parameter and
+unblocks one thread that's C<cond_wait>ing on that variable. If more than one
+thread is blocked in a C<cond_wait> on that variable, only one (and which one
+is indeterminate) will be unblocked.
+
+If there are no threads blocked in a C<cond_wait> on the variable, the signal
+is discarded. By always locking before signaling, you can (with care), avoid
+signaling before another thread has entered cond_wait().
+
+C<cond_signal> will normally generate a warning if you attempt to use it on an
+unlocked variable. On the rare occasions where doing this may be sensible, you
+can suppress the warning with:
+
+ { no warnings 'threads'; cond_signal($foo); }
+
+=item cond_broadcast VARIABLE
+
+The C<cond_broadcast> function works similarly to C<cond_signal>.
+C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in
+a C<cond_wait> on the locked variable, rather than only one.
+
+=back
+
+=head1 OBJECTS
+
+L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
+works on shared objects such that I<blessings> propagate across threads.
+
+ # Create a shared 'Foo' object
+ my $foo :shared = shared_clone({});
+ bless($foo, 'Foo');
+
+ # Create a shared 'Bar' object
+ my $bar :shared = shared_clone({});
+ bless($bar, 'Bar');
+
+ # Put 'bar' inside 'foo'
+ $foo->{'bar'} = $bar;
+
+ # Rebless the objects via a thread
+ threads->create(sub {
+ # Rebless the outer object
+ bless($foo, 'Yin');
+
+ # Cannot directly rebless the inner object
+ #bless($foo->{'bar'}, 'Yang');
+
+ # Retrieve and rebless the inner object
+ my $obj = $foo->{'bar'};
+ bless($obj, 'Yang');
+ $foo->{'bar'} = $obj;
+
+ })->join();
+
+ print(ref($foo), "\n"); # Prints 'Yin'
+ print(ref($foo->{'bar'}), "\n"); # Prints 'Yang'
+ print(ref($bar), "\n"); # Also prints 'Yang'
+
+=head1 NOTES
+
+L<threads::shared> is designed to disable itself silently if threads are not
+available. This allows you to write modules and packages that can be used
+in both threaded and non-threaded applications.
+
+If you want access to threads, you must C<use threads> before you
+C<use threads::shared>. L<threads> will emit a warning if you use it after
+L<threads::shared>.
+
+=head1 BUGS AND LIMITATIONS
+
+When C<share> is used on arrays, hashes, array refs or hash refs, any data
+they contain will be lost.
+
+ my @arr = qw(foo bar baz);
+ share(@arr);
+ # @arr is now empty (i.e., == ());
+
+ # Create a 'foo' object
+ my $foo = { 'data' => 99 };
+ bless($foo, 'foo');
+
+ # Share the object
+ share($foo); # Contents are now wiped out
+ print("ERROR: \$foo is empty\n")
+ if (! exists($foo->{'data'}));
+
+Therefore, populate such variables B<after> declaring them as shared. (Scalar
+and scalar refs are not affected by this problem.)
+
+It is often not wise to share an object unless the class itself has been
+written to support sharing. For example, an object's destructor may get
+called multiple times, once for each thread's scope exit. Another danger is
+that the contents of hash-based objects will be lost due to the above
+mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of
+this module) for how to create a class that supports object sharing.
+
+Does not support C<splice> on arrays!
+
+Taking references to the elements of shared arrays and hashes does not
+autovivify the elements, and neither does slicing a shared array/hash over
+non-existent indices/keys autovivify the elements.
+
+C<share()> allows you to C<< share($hashref->{key}) >> and
+C<< share($arrayref->[idx]) >> without giving any error message. But the
+C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing
+the error "lock can only be used on shared values" to occur when you attempt
+to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another
+thread.
+
+Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
+whether or not two shared references are equivalent (e.g., when testing for
+circular references). Use L<is_shared()/"is_shared VARIABLE">, instead:
+
+ use threads;
+ use threads::shared;
+ use Scalar::Util qw(refaddr);
+
+ # If ref is shared, use threads::shared's internal ID.
+ # Otherwise, use refaddr().
+ my $addr1 = is_shared($ref1) || refaddr($ref1);
+ my $addr2 = is_shared($ref2) || refaddr($ref2);
+
+ if ($addr1 == $addr2) {
+ # The refs are equivalent
+ }
+
+L<each()|perlfunc/"each HASH"> does not work properly on shared references
+embedded in shared structures. For example:
+
+ my %foo :shared;
+ $foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'});
+
+ while (my ($key, $val) = each(%{$foo{'bar'}})) {
+ ...
+ }
+
+Either of the following will work instead:
+
+ my $ref = $foo{'bar'};
+ while (my ($key, $val) = each(%{$ref})) {
+ ...
+ }
+
+ foreach my $key (keys(%{$foo{'bar'}})) {
+ my $val = $foo{'bar'}{$key};
+ ...
+ }
+
+View existing bug reports at, and submit any new bugs, problems, patches, etc.
+to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
+
+=head1 SEE ALSO
+
+L<threads::shared> Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/threads-shared>
+
+Annotated POD for L<threads::shared>:
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.32/shared.pm>
+
+Source repository:
+L<http://code.google.com/p/threads-shared/>
+
+L<threads>, L<perlthrtut>
+
+L<http://www.perl.com/pub/a/2002/06/11/threads.html> and
+L<http://www.perl.com/pub/a/2002/09/04/threads.html>
+
+Perl threads mailing list:
+L<http://lists.cpan.org/showlist.cgi?name=iThreads>
+
+=head1 AUTHOR
+
+Artur Bergman E<lt>sky AT crucially DOT netE<gt>
+
+Documentation borrowed from the old Thread.pm.
+
+CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>.
+
+=head1 LICENSE
+
+threads::shared is released under the same license as Perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/version/Internals.pod b/Master/tlpkg/tlperl/lib/version/Internals.pod
new file mode 100644
index 00000000000..a4f0543fe16
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/version/Internals.pod
@@ -0,0 +1,698 @@
+=head1 NAME
+
+version::Internals - Perl extension for Version Objects
+
+=head1 DESCRIPTION
+
+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
+interested in the gory details.
+
+=head1 WHAT IS A VERSION?
+
+For the purposes of this module, a version "number" is a sequence of
+positive integer values separated by one or more decimal points and
+optionally a single underscore. This corresponds to what Perl itself
+uses for a version, as well as extending the "version as number" that
+is discussed in the various editions of the Camel book.
+
+There are actually two distinct kinds of version objects:
+
+=over 4
+
+=item Decimal Versions
+
+Any version which "looks like a number", see L<Decimal Versions>. This
+also includes versions with a single decimal point and a single embedded
+underscore, see L<Alpha Versions>, even though these must be quoted
+to preserve the underscore formatting.
+
+=item Dotted-Decimal Versions
+
+Also referred to as "Dotted-Integer", these contains more than one decimal
+point and may have an optional embedded underscore, see L<Dotted-Decimal
+Versions>. This is what is commonly used in most open source software as
+the "external" version (the one used as part of the tag or tarfile name).
+A leading 'v' character is now required and will warn if it missing.
+
+=back
+
+Both of these methods will produce similar version objects, in that
+the default stringification will yield the version L<Normal Form> only
+if required:
+
+ $v = version->new(1.002); # 1.002, but compares like 1.2.0
+ $v = version->new(1.002003); # 1.002003
+ $v2 = version->new("v1.2.3"); # v1.2.3
+
+In specific, version numbers initialized as L<Decimal Versions> will
+stringify as they were originally created (i.e. the same string that was
+passed to C<new()>. Version numbers initialized as L<Dotted-Decimal Versions>
+will be stringified as L<Normal Form>.
+
+=head2 Decimal Versions
+
+These correspond to historical versions of Perl itself prior to 5.6.0,
+as well as all other modules which follow the Camel rules for the
+$VERSION scalar. A Decimal version is initialized with what looks like
+a floating point number. Leading zeros B<are> significant and trailing
+zeros are implied so that a minimum of three places is maintained
+between subversions. What this means is that any subversion (digits
+to the right of the decimal place) that contains less than three digits
+will have trailing zeros added to make up the difference, but only for
+purposes of comparison with other version objects. For example:
+
+ # Prints Equivalent to
+ $v = version->new( 1.2); # 1.2 v1.200.0
+ $v = version->new( 1.02); # 1.02 v1.20.0
+ $v = version->new( 1.002); # 1.002 v1.2.0
+ $v = version->new( 1.0023); # 1.0023 v1.2.300
+ $v = version->new( 1.00203); # 1.00203 v1.2.30
+ $v = version->new( 1.002003); # 1.002003 v1.2.3
+
+All of the preceding examples are true whether or not the input value is
+quoted. The important feature is that the input value contains only a
+single decimal. See also L<Alpha Versions>.
+
+IMPORTANT NOTE: As shown above, if your Decimal version contains more
+than 3 significant digits after the decimal place, it will be split on
+each multiple of 3, so 1.0003 is equivalent to v1.0.300, due to the need
+to remain compatible with Perl's own 5.005_03 == 5.5.30 interpretation.
+Any trailing zeros are ignored for mathematical comparison purposes.
+
+=head2 Dotted-Decimal Versions
+
+These are the newest form of versions, and correspond to Perl's own
+version style beginning with 5.6.0. Starting with Perl 5.10.0,
+and most likely Perl 6, this is likely to be the preferred form. This
+method normally requires that the input parameter be quoted, although
+Perl's after 5.8.1 can use v-strings as a special form of quoting, but
+this is highly discouraged.
+
+Unlike L<Decimal Versions>, Dotted-Decimal Versions have more than
+a single decimal point, e.g.:
+
+ # Prints
+ $v = version->new( "v1.200"); # v1.200.0
+ $v = version->new("v1.20.0"); # v1.20.0
+ $v = qv("v1.2.3"); # v1.2.3
+ $v = qv("1.2.3"); # v1.2.3
+ $v = qv("1.20"); # v1.20.0
+
+In general, Dotted-Decimal Versions permit the greatest amount of freedom
+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>.
+
+=head2 Alpha Versions
+
+For module authors using CPAN, the convention has been to note unstable
+releases with an underscore in the version string. (See L<CPAN>.) version.pm
+follows this convention and alpha releases will test as being newer than the
+more recent stable release, and less than the next stable release. Only the
+last element may be separated by an underscore:
+
+ # Declaring
+ use version 0.77; our $VERSION = version->declare("v1.2_3");
+
+ # Parsing
+ $v1 = version->parse("v1.2_3");
+ $v1 = version->parse("1.002_003");
+
+Note that you B<must> quote the version when writing an alpha Decimal version.
+The stringified form of Decimal versions will always be the same string that
+was used to initialize the version object.
+
+=head2 Regular Expressions for Version Parsing
+
+A formalized definition of the legal forms for version strings is
+included in the main F<version.pm> file. Primitives are included for
+common elements, although they are scoped to the file so they are useful
+for reference purposes only. There are two publicly accessible scalars
+that can be used in other code (not exported):
+
+=over 4
+
+=item C<$version::LAX>
+
+This regexp covers all of the legal forms allowed under the current
+version string parser. This is not to say that all of these forms
+are recommended, and some of them can only be used when quoted.
+
+For dotted decimals:
+
+ v1.2
+ 1.2345.6
+ v1.23_4
+
+The leading 'v' is optional if two or more decimals appear. If only
+a single decimal is included, then the leading 'v' is required to
+trigger the dotted-decimal parsing. A leading zero is permitted,
+though not recommended except when quoted, because of the risk that
+Perl will treat the number as octal. A trailing underscore plus one
+or more digits denotes an alpha or development release (and must be
+quoted to be parsed properly).
+
+For decimal versions:
+
+ 1
+ 1.2345
+ 1.2345_01
+
+an integer portion, an optional decimal point, and optionally one or
+more digits to the right of the decimal are all required. A trailing
+underscore is permitted and a leading zero is permitted. Just like
+the lax dotted-decimal version, quoting the values is required for
+alpha/development forms to be parsed correctly.
+
+=item C<$version::STRICT>
+
+This regexp covers a much more limited set of formats and constitutes
+the best practices for initializing version objects. Whether you choose
+to employ decimal or dotted-decimal for is a personal preference however.
+
+=over 4
+
+=item v1.234.5
+
+For dotted-decimal versions, a leading 'v' is required, with three or
+more sub-versions of no more than three digits. A leading 0 (zero)
+before the first sub-version (in the above example, '1') is also
+prohibited.
+
+=item 2.3456
+
+For decimal versions, an integer portion (no leading 0), a decimal point,
+and one or more digits to the right of the decimal are all required.
+
+=back
+
+=back
+
+Both of the provided scalars are already compiled as regular expressions
+and do not contain either anchors or implicit groupings, so they can be
+included in your own regular expressions freely. For example, consider
+the following code:
+
+ ($pkg, $ver) =~ /
+ ^[ \t]*
+ use [ \t]+($PKGNAME)
+ (?:[ \t]+($version::STRICT))?
+ [ \t]*;
+ /x;
+
+This would match a line of the form:
+
+ use Foo::Bar::Baz v1.2.3; # legal only in Perl 5.8.1+
+
+where C<$PKGNAME> is another regular expression that defines the legal
+forms for package names.
+
+=head1 IMPLEMENTATION DETAILS
+
+=head2 Equivalence between Decimal and Dotted-Decimal Versions
+
+When Perl 5.6.0 was released, the decision was made to provide a
+transformation between the old-style decimal versions and new-style
+dotted-decimal versions:
+
+ 5.6.0 == 5.006000
+ 5.005_04 == 5.5.40
+
+The floating point number is taken and split first on the single decimal
+place, then each group of three digits to the right of the decimal makes up
+the next digit, and so on until the number of significant digits is exhausted,
+B<plus> enough trailing zeros to reach the next multiple of three.
+
+This was the method that version.pm adopted as well. Some examples may be
+helpful:
+
+ equivalent
+ decimal zero-padded dotted-decimal
+ ------- ----------- --------------
+ 1.2 1.200 v1.200.0
+ 1.02 1.020 v1.20.0
+ 1.002 1.002 v1.2.0
+ 1.0023 1.002300 v1.2.300
+ 1.00203 1.002030 v1.2.30
+ 1.002003 1.002003 v1.2.3
+
+=head2 Quoting Rules
+
+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
+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.
+
+Additionally, if you quote your initializer, then the quoted value that goes
+B<in> will be be exactly what comes B<out> when your $VERSION is printed
+(stringified). If you do not quote your value, Perl's normal numeric handling
+comes into play and you may not get back what you were expecting.
+
+If you use a mathematic formula that resolves to a floating point number,
+you are dependent on Perl's conversion routines to yield the version you
+expect. You are pretty safe by dividing by a power of 10, for example,
+but other operations are not likely to be what you intend. For example:
+
+ $VERSION = version->new((qw$Revision: 1.4)[1]/10);
+ print $VERSION; # yields 0.14
+ $V2 = version->new(100/9); # Integer overflow in decimal number
+ print $V2; # yields something like 11.111.111.100
+
+Perl 5.8.1 and beyond are able to automatically quote v-strings but
+that is not possible in earlier versions of Perl. In other words:
+
+ $version = version->new("v2.5.4"); # legal in all versions of Perl
+ $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1
+
+=head2 What about v-strings?
+
+There are two ways to enter v-strings: a bare number with two or more
+decimal points, or a bare number with one or more decimal points and a
+leading 'v' character (also bare). For example:
+
+ $vs1 = 1.2.3; # encoded as \1\2\3
+ $vs2 = v1.2; # encoded as \1\2
+
+However, the use of bare v-strings to initialize version objects is
+B<strongly> discouraged in all circumstances. Also, bare
+v-strings are not completely supported in any version of Perl prior to
+5.8.1.
+
+If you insist on using bare v-strings with Perl > 5.6.0, be aware of the
+following limitations:
+
+1) For Perl releases 5.6.0 through 5.8.0, the v-string code merely guesses,
+based on some characteristics of v-strings. You B<must> use a three part
+version, e.g. 1.2.3 or v1.2.3 in order for this heuristic to be successful.
+
+2) For Perl releases 5.8.1 and later, v-strings have changed in the Perl
+core to be magical, which means that the version.pm code can automatically
+determine whether the v-string encoding was used.
+
+3) In all cases, a version created using v-strings will have a stringified
+form that has a leading 'v' character, for the simple reason that sometimes
+it is impossible to tell whether one was present initially.
+
+=head2 Version Object Internals
+
+version.pm provides an overloaded version object that is designed to both
+encapsulate the author's intended $VERSION assignment as well as make it
+completely natural to use those objects as if they were numbers (e.g. for
+comparisons). To do this, a version object contains both the original
+representation as typed by the author, as well as a parsed representation
+to ease comparisons. Version objects employ L<overload> methods to
+simplify code that needs to compare, print, etc the objects.
+
+The internal structure of version objects is a blessed hash with several
+components:
+
+ bless( {
+ 'original' => 'v1.2.3_4',
+ 'alpha' => 1,
+ 'qv' => 1,
+ 'version' => [
+ 1,
+ 2,
+ 3,
+ 4
+ ]
+ }, 'version' );
+
+=over 4
+
+=item original
+
+A faithful representation of the value used to initialize this version
+object. The only time this will not be precisely the same characters
+that exist in the source file is if a short dotted-decimal version like
+v1.2 was used (in which case it will contain 'v1.2'). This form is
+B<STRONGLY> discouraged, in that it will confuse you and your users.
+
+=item qv
+
+A boolean that denotes whether this is a decimal or dotted-decimal version.
+See L<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>.
+
+=item version
+
+An array of non-negative integers that is used for comparison purposes with
+other version objects.
+
+=back
+
+=head2 Replacement UNIVERSAL::VERSION
+
+In addition to the version objects, this modules also replaces the core
+UNIVERSAL::VERSION function with one that uses version objects for its
+comparisons. The return from this operator is always the stringified form
+as a simple scalar (i.e. not an object), but the warning message generated
+includes either the stringified form or the normal form, depending on how
+it was called.
+
+For example:
+
+ package Foo;
+ $VERSION = 1.2;
+
+ package Bar;
+ $VERSION = "v1.3.5"; # works with all Perl's (since it is quoted)
+
+ package main;
+ use version;
+
+ print $Foo::VERSION; # prints 1.2
+
+ print $Bar::VERSION; # prints 1.003005
+
+ eval "use foo 10";
+ print $@; # prints "foo version 10 required..."
+ eval "use foo 1.3.5; # work in Perl 5.6.1 or better
+ print $@; # prints "foo version 1.3.5 required..."
+
+ eval "use bar 1.3.6";
+ print $@; # prints "bar version 1.3.6 required..."
+ eval "use bar 1.004"; # note Decimal version
+ print $@; # prints "bar version 1.004 required..."
+
+
+IMPORTANT NOTE: This may mean that code which searches for a specific
+string (to determine whether a given module is available) may need to be
+changed. It is always better to use the built-in comparison implicit in
+C<use> or C<require>, rather than manually poking at C<< class->VERSION >>
+and then doing a comparison yourself.
+
+The replacement UNIVERSAL::VERSION, when used as a function, like this:
+
+ print $module->VERSION;
+
+will also exclusively return the stringified form. See L<Stringification>
+for more details.
+
+=head1 USAGE DETAILS
+
+=head2 Using modules that use version.pm
+
+As much as possible, the version.pm module remains compatible with all
+current code. However, if your module is using a module that has defined
+C<$VERSION> using the version class, there are a couple of things to be
+aware of. For purposes of discussion, we will assume that we have the
+following module installed:
+
+ package Example;
+ use version; $VERSION = qv('1.2.2');
+ ...module code here...
+ 1;
+
+=over 4
+
+=item Decimal versions always work
+
+Code of the form:
+
+ use Example 1.002003;
+
+will always work correctly. The C<use> will perform an automatic
+C<$VERSION> comparison using the floating point number given as the first
+term after the module name (e.g. above 1.002.003). In this case, the
+installed module is too old for the requested line, so you would see an
+error like:
+
+ Example version 1.002003 (v1.2.3) required--this is only version 1.002002 (v1.2.2)...
+
+=item Dotted-Decimal version work sometimes
+
+With Perl >= 5.6.2, you can also use a line like this:
+
+ 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
+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,
+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.
+
+=back
+
+=head2 Object Methods
+
+=over 4
+
+=item new()
+
+Like many OO interfaces, the new() method is used to initialize version
+objects. If two arguments are passed to C<new()>, the B<second> one will be
+used as if it were prefixed with "v". This is to support historical use of the
+C<qw> operator with the CVS variable $Revision, which is automatically
+incremented by CVS every time the file is committed to the repository.
+
+In order to facilitate this feature, the following
+code can be employed:
+
+ $VERSION = version->new(qw$Revision: 2.7 $);
+
+and the version object will be created as if the following code
+were used:
+
+ $VERSION = version->new("v2.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$ 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.
+
+A new version object can be created as a copy of an existing version
+object, either as a class method:
+
+ $v1 = version->new(12.3);
+ $v2 = version->new($v1);
+
+or as an object method:
+
+ $v1 = version->new(12.3);
+ $v2 = $v1->new(12.3);
+
+and in each case, $v1 and $v2 will be identical. NOTE: if you create
+a new object using an existing object like this:
+
+ $v2 = $v1->new();
+
+the new object B<will not> be a clone of the existing object. In the
+example case, $v2 will be an empty object of the same type as $v1.
+
+=back
+
+=over 4
+
+=item qv()
+
+An alternate way to create a new version object is through the exported
+qv() sub. This is not strictly like other q? operators (like qq, qw),
+in that the only delimiters supported are parentheses (or spaces). It is
+the best way to initialize a short version without triggering the floating
+point interpretation. For example:
+
+ $v1 = qv(1.2); # v1.2.0
+ $v2 = qv("1.2"); # also v1.2.0
+
+As you can see, either a bare number or a quoted string can usually
+be used interchangably, except in the case of a trailing zero, which
+must be quoted to be converted properly. For this reason, it is strongly
+recommended that all initializers to qv() be quoted strings instead of
+bare numbers.
+
+To prevent the C<qv()> function from being exported to the caller's namespace,
+either use version with a null parameter:
+
+ use version ();
+
+or just require version, like this:
+
+ require version;
+
+Both methods will prevent the import() method from firing and exporting the
+C<qv()> sub.
+
+=back
+
+For the subsequent examples, the following three objects will be used:
+
+ $ver = version->new("1.2.3.4"); # see "Quoting Rules"
+ $alpha = version->new("1.2.3_4"); # see "Alpha Versions"
+ $nver = version->new(1.002); # see "Decimal Versions"
+
+=over 4
+
+=item Normal Form
+
+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
+a normalized or reduced form (no extraneous zeros), and with a leading 'v':
+
+ print $ver->normal; # prints as v1.2.3.4
+ print $ver->stringify; # ditto
+ print $ver; # ditto
+ print $nver->normal; # prints as v1.2.0
+ print $nver->stringify; # prints as 1.002, see "Stringification"
+
+In order to preserve the meaning of the processed version, the
+normalized representation will always contain at least three sub terms.
+In other words, the following is guaranteed to always be true:
+
+ my $newver = version->new($ver->stringify);
+ if ($newver eq $ver ) # always true
+ {...}
+
+=back
+
+=over 4
+
+=item Numification
+
+Although all mathematical operations on version objects are forbidden
+by default, it is possible to retrieve a number which corresponds
+to the version object through the use of the $obj->numify
+method. For formatting purposes, when displaying a number which
+corresponds a version object, all sub versions are assumed to have
+three decimal places. So for example:
+
+ print $ver->numify; # prints 1.002003004
+ print $nver->numify; # prints 1.002
+
+Unlike the stringification operator, there is never any need to append
+trailing zeros to preserve the correct version value.
+
+=back
+
+=over 4
+
+=item Stringification
+
+The default stringification for version objects returns exactly the same
+string as was used to create it, whether you used C<new()> or C<qv()>,
+with one exception. The sole exception is if the object was created using
+C<qv()> and the initializer did not have two decimal places or a leading
+'v' (both optional), then the stringified form will have a leading 'v'
+prepended, in order to support round-trip processing.
+
+For example:
+
+ Initialized as Stringifies to
+ ============== ==============
+ version->new("1.2") 1.2
+ version->new("v1.2") v1.2
+ qv("1.2.3") 1.2.3
+ 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
+when used as a class method.
+
+IMPORTANT NOTE: There is one exceptional cases shown in the above table
+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
+for more details.
+
+IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by
+manually applying L<numify>() and L<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"
+into the equivalent string "1.000000". Forcing the outer version object
+to L<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
+existing version object with the same value by the very compact:
+
+ $v2 = $v1->new($v1);
+
+and be assured that both C<$v1> and C<$v2> will be completely equivalent,
+down to the same internal representation as well as stringification.
+
+=back
+
+=over 4
+
+=item Comparison operators
+
+Both C<cmp> and C<E<lt>=E<gt>> operators perform the same comparison between
+terms (upgrading to a version object automatically). Perl automatically
+generates all of the other comparison operators based on those two.
+In addition to the obvious equalities listed below, appending a single
+trailing 0 term does not change the value of a version for comparison
+purposes. In other words "v1.2" and "1.2.0" will compare as identical.
+
+For example, the following relations hold:
+
+ As Number As String Truth Value
+ ------------- ---------------- -----------
+ $ver > 1.0 $ver gt "1.0" true
+ $ver < 2.5 $ver lt true
+ $ver != 1.3 $ver ne "1.3" true
+ $ver == 1.2 $ver eq "1.2" false
+ $ver == 1.2.3.4 $ver eq "1.2.3.4" see discussion below
+
+It is probably best to chose either the Decimal notation or the string
+notation and stick with it, to reduce confusion. Perl6 version objects
+B<may> only support Decimal comparisons. See also L<Quoting Rules>.
+
+WARNING: Comparing version with unequal numbers of decimal points (whether
+explicitly or implicitly initialized), may yield unexpected results at
+first glance. For example, the following inequalities hold:
+
+ version->new(0.96) > version->new(0.95); # 0.960.0 > 0.950.0
+ version->new("0.96.1") < version->new(0.95); # 0.096.1 < 0.950.0
+
+For this reason, it is best to use either exclusively L<Decimal Versions> or
+L<Dotted-Decimal Versions> with multiple decimal points.
+
+=back
+
+=over 4
+
+=item Logical Operators
+
+If you need to test whether a version object
+has been initialized, you can simply test it directly:
+
+ $vobj = version->new($something);
+ if ( $vobj ) # true only if $something was non-blank
+
+You can also test whether a version object is an alpha version, for
+example to prevent the use of some feature not present in the main
+release:
+
+ $vobj = version->new("1.2_3"); # MUST QUOTE
+ ...later...
+ if ( $vobj->is_alpha ) # True
+
+=back
+
+=head1 AUTHOR
+
+John Peacock E<lt>jpeacock@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<perl>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/warnings/register.pm b/Master/tlpkg/tlperl/lib/warnings/register.pm
new file mode 100644
index 00000000000..57c865df522
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/warnings/register.pm
@@ -0,0 +1,51 @@
+package warnings::register;
+
+our $VERSION = '1.01';
+
+=pod
+
+=head1 NAME
+
+warnings::register - warnings import function
+
+=head1 SYNOPSIS
+
+ use warnings::register;
+
+=head1 DESCRIPTION
+
+Creates a warnings category with the same name as the current package.
+
+See L<warnings> and L<perllexwarn> for more information on this module's
+usage.
+
+=cut
+
+require warnings;
+
+sub mkMask
+{
+ my ($bit) = @_;
+ my $mask = "";
+
+ vec($mask, $bit, 1) = 1;
+ return $mask;
+}
+
+sub import
+{
+ shift;
+ my $package = (caller(0))[0];
+ if (! defined $warnings::Bits{$package}) {
+ $warnings::Bits{$package} = mkMask($warnings::LAST_BIT);
+ vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
+ $warnings::Offsets{$package} = $warnings::LAST_BIT ++;
+ foreach my $k (keys %warnings::Bits) {
+ vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
+ }
+ $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
+ vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
+ }
+}
+
+1;